MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 15.03.2019, 14:43   #1
Quartzlurch
MOF User
MOF User
Standard Frage - Kopiervorgang dauert sehr lange, zu lange!

MS Office 365
Prozessor: Intel(R) Core(TM) i7-7500U CPU @ 2.70GHz 2.90 GHz
RAM: 16,0 GB
Systemtyp: 64-Bit-Betriebssystem, x64-basierter Prozessor

Hallo Excelfreunde,

ich hätte euch gerne die Datei hochgeladen, diese ist aber, trotzdem, dass ich alles unnötige weggelassen habe viel zu groß.

Ich erkläre mal kurz um was es geht:

Von dem Bereich der Tabelle("Vokabeln") = A2:E5000, sollen per Makro alle Felder in Spalte "E" auf richtig oder Fehler überprüft werden. Alle Zeilen die "Fehler" enthalten sollen kopiert werden bis zum letzten Eintrag in Spalte A und in das Tabellenblatt("Falsche Vokabeln1") eingefügt werden. Es sollen keine doppelten Datensätze eingefügt werden.

Das Makro das ich mir zusammengestellt habe funktioniert zwar, habe aber festgestellt, dass bei der Annahme alle 5000 Datensätze seien falsch, das Makro 6 Minuten braucht um alle Datensätze zu übertragen. Dass das Makro nicht optimal erstellt ist habe ich mir schon gedacht, aber 6 Minuten sind extrem lange!

Da sollte doch bestimmt der Makroablauf optimiert werden können. Ohne eure Hilfe krieg ich das nicht hin. Wäre "Super", wenn ich den einen oder anderen Tip von euch bekäme. Über's Wochenende bin ich außer Haus, komme am späten Sonntag Abend wieder nach Hause.

Ich bedanke mich schon jetzt für jedwede Hilfe von Euch.

Hier der Code:

Option Explicit

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
' Die Zeilen falsch beantworteter Vokabeln werden
' in das Tabellenblatt "Falsche Vokabeln1" kopiert
'
'
'

Application.ScreenUpdating = False 'Schaltet den Bildschirm aus

Dim i As Long
Dim tLR As Long
Dim tarWks As Worksheet
Dim srcWks As Worksheet

Set srcWks = Worksheets("Vokabeln")
Set tarWks = Worksheets("Falsche Vokabeln1")

i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
& vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")

Sheets("Vokabeln").Select

If i = vbYes Then

Sheets("Vokabeln").Range("J18").Select
If Range("J18") = "x" Then

With srcWks
For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
If .Cells(i, 5).Value = "Fehler" Then
tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print tLR

With tarWks
.Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
srcWks.Cells(i, 5)).Formula

End With

'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
With tarWks

'Alle Formeln (richtig/Fehler) löschen
.Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

'Nur die falschen Antworten in Spalte "D" löschen
.Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

'Alle neuen Formeln (richtig/Fehler) einfügen
.Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

Range("D2").Select


End With

End If

Next i

End With


Else


With srcWks
For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
If .Cells(i, 5).Value = "Fehler" Then
tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
Debug.Print tLR

With tarWks
.Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
srcWks.Cells(i, 5)).Formula

End With

'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
With tarWks

'Nur die falschen Antworten in Spalte "D" löschen
.Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

'Alle Formeln (richtig/Fehler) löschen
.Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

'Alle doppelten Vokabeln löschen
.Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
Columns:=1, Header:=xlYes

'Alle neuen Formeln (richtig/Fehler) einfügen
.Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

Range("D2").Select

End With

End If

Next i

End With

End If

Else

MsgBox "OK, die Daten werden nicht übertragen!"

End If

Sheets("Falsche Vokabeln1").Activate
Range("D2").Select


Set srcWks = Nothing
Set tarWks = Nothing

Application.ScreenUpdating = True 'Schaltet den Bildschirm ein

End Sub
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 14:54   #2
MisterBurns
MOF Meister
MOF Meister
Standard

Also ich bin ja der Meinung, dass du mit beinahe 200 Beiträgen im Forum selbst hättest wissen können, dass wohl ohne Beispielmappe keiner deinen Code durchackern wird auf den Verdacht hin, etwas verbessern zu können...

Auch solltest du das System der Codetags mittlerweile verstanden haben, welche das Codelesen ungemein erleichtern. Das gleiche gilt für Einrückungen im Code.

Ohne nun also deinen Code gelesen zu haben, stelle ich mal die generelle Frage, wieso filterst du nicht nach Spalte E und kopierst dann sämtliche Fehlereinträge auf einmal? Das ist die schnellte Art lange Listen zu überprüfen. Schleifen sind nun mal Schnecken. Allerdings finde ich 6 Minuten bei 5000 Zeilen dennoch fragwürdig.

__________________

Schöne Grüße
Berni
MisterBurns ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 16:06   #3
feliweb
MOF User
MOF User
Standard

Hi,
ich kann mich da MisterBurns nur anschließen.
Aber füge das mal noch an den Anfang bzw ans Ende


Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten

'***Deine Anweisungen***

Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
feliweb ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 17:42   #4
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Hallo,

hier ein paar Anmerkungen:
1) Du solltest Code-Tags verwenden. Deine Buchstabensuppe ist nicht leserlich!
2) Du hast in beiden Schleifen Debug.Print-Anweisung. Nimm diese heraus, wenn Du es nicht mehr brauchst (die machen den Ablauf langsam).
3) Du hast in beiden Schleifen ein Range("D2").Select. Nimm auch das raus, das brauchst Du nicht!
4) Du beackerst einen Bereich und liest zellenweise Werte aus. Das ist langsam. Man könnte darüber nachdenken, das ganze in einer Array-Variablen zwischenzuspeichern
5a) Du löscht Bereiche und fügst Formeln in einer Schleife sehr häufig ein. Ich vermute, dass diese Aktion redundant ist (das sollte einmal nach der Schleife reichen).
5b) Warum kopierst Du eigentlich die Spalten A bis E, wenn Du D und E danach sowieso löscht. Kopier doch einfach nur A-C, dann kannst Du Dir das löschen auch sparen.
6) Ohne Beispieldatei kann man nix genaueres nicht sagen! -> Vermutlich ist es ein Folgethread von diesem (mit Beispieldatei): https://www.ms-office-forum.net/foru...40#post1917040

EDIT: Wenn man .Value2 statt .Value verwendet, kann das auch einen (kleinen) Geschwindigkeitsgewinn bringen (allerdings wird das bei Dir nicht die Lösung sein!)

__________________

Gruß
Michael

Geändert von Der Steuerfuzzi (15.03.2019 um 18:03 Uhr).
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 17:50   #5
Storax
MOF Koryphäe
MOF Koryphäe
Standard

Ohne Datei reicht vielleicht das aus (Tipps 1-3 von Der Steuerfuzzi umgesetzt + Abschalten Events)
Code:

Option Explicit

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
' Die Zeilen falsch beantworteter Vokabeln werden
' in das Tabellenblatt "Falsche Vokabeln1" kopiert
'
'
'

Dim i As Long
Dim tLR As Long
Dim tarWks As Worksheet
Dim srcWks As Worksheet

    Application.Calculation = xlCalculationManual
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set srcWks = Worksheets("Vokabeln")
    Set tarWks = Worksheets("Falsche Vokabeln1")

    i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
               & vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")

    Sheets("Vokabeln").Select

    If i = vbYes Then

        Sheets("Vokabeln").Range("J18").Select
        If Range("J18") = "x" Then

            With srcWks
                For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
                    If .Cells(i, 5).Value = "Fehler" Then
                        tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                        ' Debug.Print tLR

                        With tarWks
                            .Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
                                                                                        srcWks.Cells(i, 5)).Formula

                        End With

                        'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
                        With tarWks

                            'Alle Formeln (richtig/Fehler) löschen
                            .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

                            'Nur die falschen Antworten in Spalte "D" löschen
                            .Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

                            'Alle neuen Formeln (richtig/Fehler) einfügen
                            .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                            "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

                            'Range("D2").Select


                        End With

                    End If

                Next i

            End With


        Else


            With srcWks
                For i = 1 To .Cells(.Rows.Count, 5).End(xlUp).Row
                    If .Cells(i, 5).Value = "Fehler" Then
                        tLR = tarWks.Cells(Rows.Count, "A").End(xlUp).Row + 1
                        'Debug.Print tLR

                        With tarWks
                            .Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
                                                                                        srcWks.Cells(i, 5)).Formula

                        End With

                        'Alle alten Formeln im Sheets("Falsche Vokabeln1"), in Spalte E löschen und neue Formeln einfügen.
                        With tarWks

                            'Nur die falschen Antworten in Spalte "D" löschen
                            .Range("$D$2:$D" & .Cells(Rows.Count, "D").End(xlUp).Row).ClearContents

                            'Alle Formeln (richtig/Fehler) löschen
                            .Range("E2:E" & .Cells(Rows.Count, "E").End(xlUp).Row).ClearContents

                            'Alle doppelten Vokabeln löschen
                            .Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
                                    Columns:=1, Header:=xlYes

                            'Alle neuen Formeln (richtig/Fehler) einfügen
                            .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                            "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"

                            ' Range("D2").Select

                        End With

                    End If

                Next i

            End With

        End If

    Else

        MsgBox "OK, die Daten werden nicht übertragen!"

    End If

    Sheets("Falsche Vokabeln1").Activate
    Range("D2").Select


    Set srcWks = Nothing
    Set tarWks = Nothing

    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

__________________

How do I ask a good question?

In a lot questions the OP has no idea what they're doing, they've found code on the internet, mixed it around and got something. They don't understand why that something doesn't work.
Usually, in these questions, the original poster is rather clueless, helping them on the question is only spoon feeding them, and there is little to no chance the question will help anyone in the future.

Press any key to continue - or any other key to abort.

Spoon feeding: provide (someone) with so much help or information that they do not need to think for themselves.
Storax ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 19:05   #6
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo an Alle,

danke für eure Aufmerksamkeit. Habe eine wirklich abgespeckte Version in einem Arbeitsblatt für euch im Anhang. Da ist kein Autofilter mehr drin und die vier Module mit diversen anderen Macros fehlen auch. Kann ja leider nur 97 kB uploaden. Die Spalten ("A : D") müsstet ihr dann eben bis 5000 runterziehen. Die Spalte "B"= Lösung, ist normalerweise ausgeblendet.

Warum ich das wie gemacht habe? ich kann's leider nicht besser. Wegen dem Code zu präsentieren, habe Probleme mit Excel-Jeannie. hatte das vor vielen Jahren unter Excel 2003 eingesetzt aber mit der Version von Office 365 Home gelingt mir das nicht, da gab's eine Fehlermeldung die ich leider vergaß.

Gruß Horst
Angehängte Dateien
Dateityp: xlsm Kopieren ohne Doppelte_Beispielmappe.xlsm (97,6 KB, 2x aufgerufen)
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 19:11   #7
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Storax,

Danke für deine Hilfe. Habe den von dir geänderten Code probiert, da gab's den Laufzeitfehler 1004 in folgendem Bereich:

With tarWks
.Range(.Cells(tLR, 1), .Cells(tLR, 5)).Value = srcWks.Range(srcWks.Cells(i, 1), _
srcWks.Cells(i, 5)).Formula

Gruß Horst
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.03.2019, 19:58   #8
Storax
MOF Koryphäe
MOF Koryphäe
Standard

Den Teil habe ich nicht geändert und wenn Du das nicht wechseln kannst, ooh ooh.

Nimm die Zeilentrennung raus, das dürfte beim Kopieren schief gegangen sein.

__________________

How do I ask a good question?

In a lot questions the OP has no idea what they're doing, they've found code on the internet, mixed it around and got something. They don't understand why that something doesn't work.
Usually, in these questions, the original poster is rather clueless, helping them on the question is only spoon feeding them, and there is little to no chance the question will help anyone in the future.

Press any key to continue - or any other key to abort.

Spoon feeding: provide (someone) with so much help or information that they do not need to think for themselves.
Storax ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.03.2019, 10:16   #9
Der Steuerfuzzi
MOF Profi
MOF Profi
Standard

Ich habe mal versucht, den Code umzubauen. Bin mir zwar nicht sicher, ob er das macht, was Du willst, aber probier es mal aus:
Code:

Sub Zeilen_in_Falsche_Vokabeln1_kopieren()
    ' Die Zeilen falsch beantworteter Vokabeln werden
    ' in das Tabellenblatt "Falsche Vokabeln1" kopiert

    Dim i       As Long
    Dim tarWks  As Worksheet
    Dim srcWks  As Worksheet
        
    i = MsgBox("Sollen die Daten wirklich übertragen werden?" _
        & vbCr & "Gute Entscheidung nochmal zu wiederholen!!!", vbYesNo + vbQuestion, "Frage vom Lehrer!")
    
    If i = vbYes Then
        Application.ScreenUpdating = False   'Schaltet den Bildschirm aus
        Set srcWks = Worksheets("Vokabeln")
        Set tarWks = Worksheets("Falsche Vokabeln1")
        ' Schreibschutz_aufheben Makro
        ' Schreibschutz aufheben "Vokabeln" und Spalten einfügen!
        Schutz_aus srcWks
        Schutz_aus tarWks
        With srcWks
             'Autofilter: nur "Fehler" sichtbar
             If Not .AutoFilterMode Then Range("A1").AutoFilter
             Range("A1").AutoFilter Field:=5, Criteria1:="Fehler"
             'Sichtbare Zellen kopieren
             .Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy tarWks.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
             If Sheets("Vokabeln").AutoFilterMode Then Range("A1").AutoFilter
             'Fomel eintragen
             With tarWks
                 .Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
                         "=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"
             End With
        End With
        If srcWks.Range("J18") <> "x" Then
             With tarWks
                'Alle doppelten Vokabeln löschen
                .Range("$A$1:$E" & .Cells(Rows.Count, "A").End(xlUp).Row).RemoveDuplicates _
                 Columns:=1, Header:=xlYes
             End With
         End If
        Schutz_an srcWks
        Schutz_an tarWks
        tarWks.Activate
        Set srcWks = Nothing
        Set tarWks = Nothing
        Application.ScreenUpdating = True   'Schaltet den Bildschirm ein
    Else
        MsgBox "OK, die Daten werden nicht übertragen!"
    End If
End Sub
Sub Schutz_aus(wks As Worksheet)
    wks.Unprotect Password:=""
    wks.Columns("A:H").Hidden = False
End Sub
Sub Schutz_an(wks As Worksheet)
    wks.Range("B:B, G:G").EntireColumn.Hidden = True
    wks.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

__________________

Gruß
Michael
Der Steuerfuzzi ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.03.2019, 16:34   #10
Quartzlurch
Threadstarter Threadstarter
MOF User
MOF User
Standard

Hallo Michael,

vielen Dank für dein Engagement und sorry, dass ich mich erst jetzt zurück melde. Zu dem veränderten Code, das sind "zwei Unterschiede wie Tag und Nacht"! Die Schnelligkeit der Übertragung ist vllt. gerade mal 1 Sekunde. Wahnsinn. Ich habe noch ein wenig Probleme den Code dem Autofilter anzupassen in meinem eigentlichen Arbeitsblatt. Ich versuche es alleine hinzukriegen, wenn nicht melde ich mich nochmal. Nochmals: "recht herzlichen Dank an dich!"

P.S:
Wäre schön, wenn Du mir noch ein wenig Infos zum "besseren Verstehen" zukommen lassen könntest über folgende Teile:

If Not .AutoFilterMode Then Range("A1").AutoFilter
Range("A1").AutoFilter Field:=5, Criteria1:="Fehler"

.Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy tarWks.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
If Sheets("Vokabeln").AutoFilterMode Then Range("A1").AutoFilter

Range("E2:E" & .Cells(Rows.Count, "A").End(xlUp).Row).FormulaR1C1 = _
"=IF(ISBLANK(RC[-1]),"""",IF(ISNA(MATCH(RC[-1],RC[1],0)), ""Fehler"",""richtig""))"
Quartzlurch ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 3 (Registrierte Benutzer: 2, Besucher: 1)
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 17:46 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.