VBA - For Schleife - Übernimmt nicht alle Daten
12.09.2024 12:28:57
Hungerhaken
ich bin seit einiger Zeit stiller Leser einiger Threads und hole mir Tipps & Tricks.
Nun habe ich aber ein Problem, zu dem ich einfach keine Lösung finde.
Der Code, soll aus zwei Blättern (raw data & Datenbank) Namen vergleichen und bei Treffern die gesamte Zeile in ein neues Blatt kopieren und einfügen.
Der Name des neuen Blattes erstellt sich aus dem Blatt "Datenbank" aus Spalte C und D.
Die meisten Daten werden auch, so wie oben beschrieben, übertragen und erstellt. Beim genauen hinsehen aber, fällt auf, dass einige Daten nicht übernommen werden.
Beispiel:
Name: Müller
In raw data und Datenbank befinden sich die Namen Müller, Meyer, und Kunst.
Meyer und Kunst werden in ein neues Blatt kopiert und eingefügt. Müller aber nicht. Obwohl die Daten vorhanden sind.
Ich bin davon ausgegangen, dass Excel zu "schnell" gewesen ist und die Daten "übersehen" hat. Dementsprechend habe ich Application.Wait eingefügt mit einer Wartezeit von 0.5 sekunden. (raw Data enthält knapp 3000 Einträge und Datenbank wird stetig erweitert, bei 1 Sekunde dauert das ganze ewig :) )
Könnt ihr mir helfen, dass die Daten alle erfasst werden?
Dim wsRawData As Worksheet
Dim wsDatabase As Worksheet
Dim wsNew As Worksheet
Dim lastRowRawData As Long
Dim lastRowDatabase As Long
Dim i As Long, j As Long, k As Long
Dim newSheetName As String
Set wsRawData = ThisWorkbook.Sheets("raw data")
Set wsDatabase = ThisWorkbook.Sheets("Datenbank")
lastRowRawData = wsRawData.Cells(wsRawData.Rows.Count, "A").End(xlUp).Row
lastRowDatabase = wsDatabase.Cells(wsDatabase.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastRowRawData
For j = 2 To lastRowDatabase
If wsRawData.Cells(i, 1).Value = wsDatabase.Cells(j, 1).Value And wsRawData.Cells(i, 2).Value = wsDatabase.Cells(j, 2).Value Then
newSheetName = wsDatabase.Cells(j, 3).Value & " " & wsDatabase.Cells(j, 4).Value
If WorksheetExists(newSheetName) Then
Set wsNew = ThisWorkbook.Sheets(newSheetName)
Else
Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsNew.Name = newSheetName
wsRawData.Rows(1).Copy Destination:=wsNew.Rows(1)
End If
k = wsNew.Cells(wsNew.Rows.Count, "A").End(xlUp).Row + 1
wsRawData.Rows(i).Copy Destination:=wsNew.Rows(k)
End If
Application.Wait Now + TimeValue("0:00:01") / 2
Next j
Next i
End SubAnzeige