Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1600to1604
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro definitiv zu langsam

Makro definitiv zu langsam
12.01.2018 10:45:18
Burak
Moin Moin,
also jetzt geht es um Performance, da das Makro für seine Aufgabe bei einem Testbeispiel mit 3 Werten etwa 30 sekunden braucht, das ganze aber eher hunderte bis tausende Einträge haben wird.
Sub zusammenfuegen()
'Deklaration der Variablen
Dim schrott As Byte
Dim Zeilenzahlschrott As Long
Dim Zeilenzahlaoi As Long
Dim Zeilenzahllog As Long
schrott = 0
'Blatt leeren
Worksheets("Gesamtliste").Cells.Clear
'Zeilen des LogImports zählen
With Worksheets("LogImport")
Zeilenzahllog = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'LogImport-Schleife
For i = 2 To Zeilenzahllog
'Zeilen der Schrottliste zählen
With Worksheets("Schrottliste")
Zeilenzahlschrott = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
'Überprüfung ob verschrottet
For j = 2 To Zeilenzahlschrott
If Worksheets("Logimport").Range("B" & i).Value = Worksheets("Schrottliste").Range("A" &  _
j).Value Then
schrott = 1
End If
Next j
'Wenn nicht verschrottet
If schrott = 0 Then
'Linien-Schleife
For l = 1 To 5
'Zeilenzählen
With Worksheets("R" & l)
Zeilenzahlaoi = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
'Logimport-AOI-Vergleich-Schleife
For k = 2 To Zeilenzahlaoi
'Bedingung Barcode identisch
If Worksheets("Logimport").Range("B" & i).Value = Worksheets("R" & l).Range("B" & k). _
Value Then
'Bedingung Bauteilname identisch
If Worksheets("Logimport").Range("C" & i).Value = Worksheets("R" & l).Range("G" & k) _
.Value Then
'Bedingung PIN identisch
If Worksheets("Logimport").Range("D" & i).Value = Worksheets("R" & l).Range("J" &  _
k).Value Then
'Bedingung Analyse-Typ identisch
If Worksheets("Logimport").Range("F" & i).Value = Worksheets("R" & l).Range("K"  _
& k).Value Then
'Werteübernahme der übereinstimmenden Zeilen
With Worksheets("Gesamtliste")
.Range("A" & i).Value = Worksheets("R" & l).Range("A" & k).Value
.Range("B" & i).Value = Worksheets("R" & l).Range("B" & k).Value
.Range("C" & i).Value = Worksheets("R" & l).Range("C" & k).Value
.Range("D" & i).Value = Worksheets("R" & l).Range("D" & k).Value
.Range("E" & i).Value = Worksheets("R" & l).Range("E" & k).Value
.Range("F" & i).Value = Worksheets("R" & l).Range("F" & k).Value
.Range("G" & i).Value = Worksheets("R" & l).Range("G" & k).Value
.Range("H" & i).Value = Worksheets("R" & l).Range("H" & k).Value
.Range("I" & i).Value = Worksheets("R" & l).Range("I" & k).Value
.Range("J" & i).Value = Worksheets("R" & l).Range("J" & k).Value
.Range("K" & i).Value = Worksheets("R" & l).Range("K" & k).Value
.Range("L" & i).Value = Worksheets("R" & l).Range("L" & k).Value
.Range("M" & i).Value = Worksheets("Logimport").Range("G" & i).Value
.Range("N" & i).Value = Worksheets("Logimport").Range("H" & i).Value
.Range("O" & i).Value = Worksheets("Logimport").Range("I" & i).Value
.Range("P" & i).Value = Worksheets("Logimport").Range("J" & i).Value
.Range("Q" & i).Value = Worksheets("Logimport").Range("K" & i).Value
.Range("R" & i).Value = Worksheets("Logimport").Range("L" & i).Value
.Range("S" & i).Value = Worksheets("Logimport").Range("M" & i).Value
.Range("T" & i).Value = Worksheets("Logimport").Range("N" & i).Value
End With
End If
End If
End If
End If
Next k
Next l
End If
schrott = 0
Next i
'Überschriften setzen mit Formatierung
With Worksheets("Gesamtliste")
.Range("A1:L1").Value = Worksheets("R1").Range("A1:L1").Value
.Range("M1:T1").Value = Worksheets("Logimport").Range("G1:N1").Value
.Rows(1).Font.Bold = True
.Columns("A:A").ColumnWidth = 7.43
.Columns("B:B").ColumnWidth = 13.71
.Columns("C:C").ColumnWidth = 8.29
.Columns("D:D").ColumnWidth = 14.43
.Columns("E:E").ColumnWidth = 22.14
.Columns("F:F").ColumnWidth = 6.57
.Columns("G:G").ColumnWidth = 7.43
.Columns("H:H").ColumnWidth = 8.14
.Columns("I:I").ColumnWidth = 9.14
.Columns("J:J").ColumnWidth = 3.43
.Columns("K:K").ColumnWidth = 10.43
.Columns("L:L").ColumnWidth = 7.86
.Columns("M:M").ColumnWidth = 10.29
.Columns("N:N").ColumnWidth = 8.29
.Columns("O:O").ColumnWidth = 9.86
.Columns("P:P").ColumnWidth = 10.57
.Columns("Q:Q").ColumnWidth = 10
.Columns("R:R").ColumnWidth = 10.71
.Columns("S:S").ColumnWidth = 5.43
.Columns("T:T").ColumnWidth = 7.29
End With
End Sub
Also habe das im Sheet Logimport Einträge (derzeit 3 ohne Überschrift) wo in Spalte B jeder Eintrag erst geguckt wird, ob er im Sheet Schrottliste in Spalte A vorhanden ist. Wenn ja, dann soll er zum nächsten Wert des Logimports springen. Wenn nicht, soll er 4 zusammenhängende Werte auf 5 Sheets (R1 - R5) suchen und bei einem Fund die Werte in das Sheet Gesamtliste eintragen.
Mir kam auf jeden Fall die Idee, dass er beide (inneren) Schleifen ja abbrechen kann, sobald er den Barcode in der Schrottliste oder die 4 zusammenhängede Werte in den R1-R5 gefunden hat, da die Werte nicht doppelt vorkommen können.
Das würde es etwas performanter machen aber wird glaube ich nicht ausreichen :)
Bin für jede Idee dankbar
Freundliche Grüße

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro definitiv zu langsam
12.01.2018 10:51:34
Sepp
Hallo Burak,
da wäre eine Beispieldatei mit aussagekräftiger Beschreibung des Wunschergebnisses sehr hilfreich.
Gruß Sepp

AW: Makro definitiv zu langsam
12.01.2018 11:00:32
Burak
hab ich mir schon gedacht.
Ist fertig, musste halt vieles entfernen und anderen filehoster finden, da zu groß.
https://ufile.io/fqzpz
Hab das gekürzt, hoffe hilft trotzdem
wird immer besser...
12.01.2018 11:53:29
Werner
Hallo Burak,
...statt auf eine Lösungsvorschlag/Versuch zu reagieren wird ein neuer Beitrag aufgemacht.
Helfen macht Spaß - ich bin raus.
Gruß Werner
Anzeige
AW: wird immer besser...
12.01.2018 12:17:44
Burak
häh? ich weiß nicht was du meinst? hatte mal ein ähnlichen Post, war auch selbe datei aber andere Code-Teil :O
AW: Makro definitiv zu langsam
12.01.2018 11:56:52
Sepp
Hallo Burak,
probier mal.
' **********************************************************************
' Modul: zusammenfuegen Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfuegen()
Dim objLog As Worksheet, objGes As Worksheet, objSch As Worksheet
Dim lngRow As Long, lngMax As Long, lngIndex As Long, lngN As Long, lngI As Long
Dim varRet As Variant, varOutput() As Variant
Dim strComp1 As String, strComp2 As String

Set objGes = Worksheets("Gesamtliste")
Set objLog = Worksheets("LogImport")
Set objSch = Worksheets("Schrottliste")

objGes.Cells.Clear

'Zeilen des LogImports zählen
With objLog
  lngMax = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
  Redim varOutput(1 To lngMax, 1 To 20)
  For lngRow = 2 To lngMax
    varRet = Application.Match(.Cells(lngRow, 2), objSch.Columns(1), 0)
    If Not IsNumeric(varRet) Then
      For lngN = 1 To 5
        varRet = Application.Match(.Cells(lngRow, 2), Sheets("R" & lngN).Columns(2), 0)
        If IsNumeric(varRet) Then
          strComp1 = .Range("C" & lngRow) & .Range("D" & lngRow) & .Range("F" & lngRow)
          
          strComp2 = Sheets("R" & lngN).Range("G" & varRet) & _
            Sheets("R" & lngN).Range("J" & varRet) & Sheets("R" & lngN).Range("K" & varRet)
          
          If strComp1 = strComp2 Then
            lngIndex = lngIndex + 1
            For lngI = 1 To 20
              If lngI <= 12 Then
                varOutput(lngIndex, lngI) = Sheets("R" & lngN).Cells(varRet, lngI)
              Else
                varOutput(lngIndex, lngI) = objLog.Cells(lngRow, lngI - 6)
              End If
            Next
          End If
          Exit For
        End If
      Next
    End If
  Next
End With

If lngIndex > 0 Then
  With objGes
    .Cells(2, 1).Resize(UBound(varOutput, 1), UBound(varOutput, 2)) = varOutput
    'Überschriften setzen mit Formatierung
    .Range("A1:L1").Value = Worksheets("R1").Range("A1:L1").Value
    .Range("M1:T1").Value = objLog.Range("G1:N1").Value
    .Rows(1).Font.Bold = True
    .Columns("A:A").ColumnWidth = 7.43
    .Columns("B:B").ColumnWidth = 13.71
    .Columns("C:C").ColumnWidth = 8.29
    .Columns("D:D").ColumnWidth = 14.43
    .Columns("E:E").ColumnWidth = 22.14
    .Columns("F:F").ColumnWidth = 6.57
    .Columns("G:G").ColumnWidth = 7.43
    .Columns("H:H").ColumnWidth = 8.14
    .Columns("I:I").ColumnWidth = 9.14
    .Columns("J:J").ColumnWidth = 3.43
    .Columns("K:K").ColumnWidth = 10.43
    .Columns("L:L").ColumnWidth = 7.86
    .Columns("M:M").ColumnWidth = 10.29
    .Columns("N:N").ColumnWidth = 8.29
    .Columns("O:O").ColumnWidth = 9.86
    .Columns("P:P").ColumnWidth = 10.57
    .Columns("Q:Q").ColumnWidth = 10
    .Columns("R:R").ColumnWidth = 10.71
    .Columns("S:S").ColumnWidth = 5.43
    .Columns("T:T").ColumnWidth = 7.29
  End With
End If

Set objLog = Nothing
Set objGes = Nothing
Set objSch = Nothing

End Sub

Gruß Sepp

Anzeige
AW: Makro definitiv zu langsam
12.01.2018 12:22:08
Burak
Effizienz 110% :O
aber Sheet LogImport Zeile 2 müsste er in der Gesamtliste auch auflisten, da der Barcode nicht in der Schrottliste steht und alle 4 Werte (Masterbarcode, BT Name, Analyse Typ und Pin) kombiniert anders ist als in Zeile 1 und auch vorkommt in Sheet "R2".
AW: Makro definitiv zu langsam
12.01.2018 13:39:54
Sepp
Hallo Burak,
stimmt, hatte ein 'Exit For' zuviel drinnen!
' **********************************************************************
' Modul: zusammenfuegen Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub zusammenfuegen()
Dim objLog As Worksheet, objGes As Worksheet, objSch As Worksheet
Dim lngRow As Long, lngMax As Long, lngIndex As Long, lngN As Long, lngI As Long
Dim varRet As Variant, varOutput() As Variant
Dim strComp1 As String, strComp2 As String

Set objGes = Worksheets("Gesamtliste")
Set objLog = Worksheets("LogImport")
Set objSch = Worksheets("Schrottliste")

objGes.Cells.Clear

'Zeilen des LogImports zählen
With objLog
  lngMax = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
  Redim varOutput(1 To lngMax, 1 To 20)
  For lngRow = 2 To lngMax
    varRet = Application.Match(.Cells(lngRow, 2), objSch.Columns(1), 0)
    If Not IsNumeric(varRet) Then
      For lngN = 1 To 5
        varRet = Application.Match(.Cells(lngRow, 2), Sheets("R" & lngN).Columns(2), 0)
        If IsNumeric(varRet) Then
          strComp1 = .Range("C" & lngRow) & .Range("D" & lngRow) & .Range("F" & lngRow)
          
          strComp2 = Sheets("R" & lngN).Range("G" & varRet) & _
            Sheets("R" & lngN).Range("J" & varRet) & Sheets("R" & lngN).Range("K" & varRet)
          
          If strComp1 = strComp2 Then
            lngIndex = lngIndex + 1
            For lngI = 1 To 20
              If lngI <= 12 Then
                varOutput(lngIndex, lngI) = Sheets("R" & lngN).Cells(varRet, lngI)
              Else
                varOutput(lngIndex, lngI) = objLog.Cells(lngRow, lngI - 6)
              End If
            Next
          End If
        End If
      Next
    End If
  Next
End With

If lngIndex > 0 Then
  With objGes
    .Cells(2, 1).Resize(UBound(varOutput, 1), UBound(varOutput, 2)) = varOutput
    'Überschriften setzen mit Formatierung
    .Range("A1:L1").Value = Worksheets("R1").Range("A1:L1").Value
    .Range("M1:T1").Value = objLog.Range("G1:N1").Value
    .Rows(1).Font.Bold = True
    .Columns("A:A").ColumnWidth = 7.43
    .Columns("B:B").ColumnWidth = 13.71
    .Columns("C:C").ColumnWidth = 8.29
    .Columns("D:D").ColumnWidth = 14.43
    .Columns("E:E").ColumnWidth = 22.14
    .Columns("F:F").ColumnWidth = 6.57
    .Columns("G:G").ColumnWidth = 7.43
    .Columns("H:H").ColumnWidth = 8.14
    .Columns("I:I").ColumnWidth = 9.14
    .Columns("J:J").ColumnWidth = 3.43
    .Columns("K:K").ColumnWidth = 10.43
    .Columns("L:L").ColumnWidth = 7.86
    .Columns("M:M").ColumnWidth = 10.29
    .Columns("N:N").ColumnWidth = 8.29
    .Columns("O:O").ColumnWidth = 9.86
    .Columns("P:P").ColumnWidth = 10.57
    .Columns("Q:Q").ColumnWidth = 10
    .Columns("R:R").ColumnWidth = 10.71
    .Columns("S:S").ColumnWidth = 5.43
    .Columns("T:T").ColumnWidth = 7.29
  End With
End If

Set objLog = Nothing
Set objGes = Nothing
Set objSch = Nothing

End Sub

Gruß Sepp

Anzeige
AW: Makro definitiv zu langsam
12.01.2018 14:06:35
Burak
also ja bei der Beispiel-Datei funktioniert es, aber nicht mehr bei der ungekürzten Fassung.
Also hier wird wieder die zweite Zeile nicht kopiert.
Daher hier nochmal die Datei ungekürzt.
http://filehorst.de/d/cttwntAb
Ne Idee woran es liegt?
AW: Makro definitiv zu langsam
12.01.2018 14:25:10
Burak
ah hab zumindest den Unterschied gefunden bzw woran es liegt (nur nich im Code)
Wenn zwei Zeilen mit dem selben Masterbarcode im selben Sheet (hier R3) liegen, dann findet er die zweite nicht.
AW: Makro definitiv zu langsam
12.01.2018 14:25:54
Sepp
Hallo Burak,
kann eine Kombination, also ein Treffer, auch mehrfach in einem R-Sheet vorkommen?
Wie viele Einträge erwartest du bei dem zweiten File?
Gruß Sepp

Anzeige
AW: Makro definitiv zu langsam
12.01.2018 14:27:35
Burak
Ja kann und wird es definitiv, bzw doppelte Einträge können nur im selben Sheet vorkommen. Wenn Sie in R1 auftauchen, können sie nicht in R2-R5 auftauchen.
Schwer zu sagen aber werden hunderte bis tausende sein.
AW: Makro definitiv zu langsam
12.01.2018 14:49:49
Sepp
Hallo Burak,
ich meinte wie viele im Beispiel! Ich bekomme nur drei Treffer und was ich per Hand feststellen konnte, sind es auch nicht mehr.
Probier noch mal, habe den Code jetzt auf mehrere Fundstellen in den R-Blättern erweitert.
' **********************************************************************
' Modul: zusammenfuegen1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub collectData()
Dim objLog As Worksheet, objGes As Worksheet, objSch As Worksheet, objFind As Range
Dim lngRow As Long, lngMax As Long, lngIndex As Long, lngN As Long, lngI As Long
Dim varRet As Variant, varOutput() As Variant
Dim strComp1 As String, strComp2 As String, strFirst As String
Dim bolFound As Boolean

'Objectvariablen zuweisen
Set objGes = Worksheets("Gesamtliste")
Set objLog = Worksheets("LogImport")
Set objSch = Worksheets("Schrottliste")

'Gesamtliste leeren
objGes.Cells.Clear

With objLog
  'Anzahl der Zeilen in LogImport ermitteln
  lngMax = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)
  'Ausgabearray dimensionieren
  Redim varOutput(1 To 50000, 1 To 20)
  'Zeilen durchlaufen
  For lngRow = 2 To lngMax
    'Barcode in Schrottliste suchen
    varRet = Application.Match(.Cells(lngRow, 2), objSch.Columns(1), 0)
    'Wenn Bacode NICHT gefunden, dann
    If Not IsNumeric(varRet) Then
      'R-Tabellen durchlaufen
      For lngN = 1 To 5
        'Gefundenvariable auf False setzen
        bolFound = False
        'Suchvariablen reseten
        Set objFind = Nothing
        strFirst = ""
        'Barcode in R-Sheet suchen
        Set objFind = Sheets("R" & lngN).Columns(2).Find(What:=.Cells(lngRow, 2), _
          LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=False, SearchFormat:=False)
        'Wenn gefunden, dann
        If Not objFind Is Nothing Then
          'Adresse des ersten Treffers merken
          strFirst = objFind.Address
          'Gefunden auf True setzen
          bolFound = True
          'Suchschleife
          Do
            'Vergleichsstring aus LogImport
            strComp1 = .Range("C" & lngRow) & .Range("D" & lngRow) & .Range("F" & lngRow)
            'Vergleichsstring aus R-Sheet
            strComp2 = Sheets("R" & lngN).Range("G" & objFind.Row) & _
              Sheets("R" & lngN).Range("J" & objFind.Row) & _
              Sheets("R" & lngN).Range("K" & objFind.Row)
            'Wenn beide Vergleichsstrings ident, dann
            If strComp1 = strComp2 Then
              lngIndex = lngIndex + 1
              If lngIndex > 50000 Then Exit For
              'Daten in Ausgabearray schreiben
              For lngI = 1 To 20
                If lngI <= 12 Then 'Daten aus R-Sheet
                  varOutput(lngIndex, lngI) = Sheets("R" & lngN).Cells(objFind.Row, lngI)
                Else 'Daten aus LogImport
                  varOutput(lngIndex, lngI) = objLog.Cells(lngRow, lngI - 6)
                End If
              Next
            End If
            'Weitersuchen
            Set objFind = Sheets("R" & lngN).Columns(2).FindNext(objFind)
            'Abbruchsbedingungen der Suchschleife
          Loop While Not objFind Is Nothing And strFirst <> objFind.Address
        End If
        'Wenn in einem R-Sheet gefunden, dann Schleife verlassen
        If bolFound Then Exit For
      Next
    End If
  Next
End With

'Wenn Daten im Ausgabearray
If lngIndex > 0 Then
  With objGes
    'Daten in Gesamtliste ab Zeile 2 schreiben
    .Cells(2, 1).Resize(lngIndex, 20) = varOutput
    'Überschriften setzen mit Formatierung
    .Range("A1:L1").Value = Worksheets("R1").Range("A1:L1").Value
    .Range("M1:T1").Value = objLog.Range("G1:N1").Value
    .Rows(1).Font.Bold = True
    .Columns("A:A").ColumnWidth = 7.43
    .Columns("B:B").ColumnWidth = 13.71
    .Columns("C:C").ColumnWidth = 8.29
    .Columns("D:D").ColumnWidth = 14.43
    .Columns("E:E").ColumnWidth = 22.14
    .Columns("F:F").ColumnWidth = 6.57
    .Columns("G:G").ColumnWidth = 7.43
    .Columns("H:H").ColumnWidth = 8.14
    .Columns("I:I").ColumnWidth = 9.14
    .Columns("J:J").ColumnWidth = 3.43
    .Columns("K:K").ColumnWidth = 10.43
    .Columns("L:L").ColumnWidth = 7.86
    .Columns("M:M").ColumnWidth = 10.29
    .Columns("N:N").ColumnWidth = 8.29
    .Columns("O:O").ColumnWidth = 9.86
    .Columns("P:P").ColumnWidth = 10.57
    .Columns("Q:Q").ColumnWidth = 10
    .Columns("R:R").ColumnWidth = 10.71
    .Columns("S:S").ColumnWidth = 5.43
    .Columns("T:T").ColumnWidth = 7.29
  End With
End If

'Variablen löschen
Set objLog = Nothing
Set objGes = Nothing
Set objSch = Nothing
Set objFind = Nothing
End Sub

Gruß Sepp

Anzeige
AW: Makro definitiv zu langsam
12.01.2018 15:00:39
Burak
Also wenn ich dich jetz richtig verstehe, kann die kombination aus Masterbarcode, BTName, PIN und AnalyseTyp nur ein einziges Mal vorkommen in den R-Sheets
Das heißt jeder Datensatz im LogImport-Sheet kann nur einen Datensatz in den R-Sheets haben.
Dafür müssen aber halt auch alle 4 Werte übereinstimmen.
Jetzt funktioniert das Makro ausreichend, es findet alle drei Datensätze.
Denselben Masterbarcode (also Datensatz 1 und 2) findet er nur wenn es sich im selben Tabellenblatt befindet, aber das ist auch vollkommen ausreichend da es sich nicht woanders befinden kann.
Ich danke dir vielmals und versuche deinen Code nächste Woche auch zu verstehen :D
Mache jetzt Feierabend.
Wünsche dir noch ein schönes Wochenende!
PS: Falls du die ungekürzte Datei runtergeladen hast, würde ich dich darum bitten sie wieder zu löschen.
Anzeige
OK, habe ich gelöscht! o.T.
12.01.2018 15:46:53
Sepp
Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige