Fehler im Kopier-Makro
19.01.2020 19:44:55
Markus
mit folgendem Makro möchte ich, bei Inhalt in den betreffenden Zellen, einen Kopiervorgang in eine andere Mappe starten. Das Makro soll in Spalte C ab Zeile 10 bis Zeile 50 in 5er Schritten (sind verbundene Zellen im Tabellenblatt, nach 5 Zeilen erfolgt ggf. ein neuer Eintrag) schauen, ob ein Inhalt vorhanden ist und ggf. den Kopiervorgang starten.
Bsp: in Zelle C10 und C15 ist ein Eintrag vorhanden - folglich soll der Kopiervorgang für die Zeilen 10 und 15 gestartet werden. Leider kopiert mir das Makro maximal 3 Einträge, obwohl Einträge auch noch in bspw. Zeile C45 vorhanden sind.
Findet ihr einen Fehler im Makro?:
Public Sub Kopieren()
Dim wb_quelle As Workbook
Dim wb_ziel As Workbook
Dim ws_ziel As Worksheet
Dim sh As Worksheet
On Error Resume Next
Set wb_ziel = Workbooks("xyz.xlsm")
On Error GoTo 1
If wb_ziel Is Nothing Then
Workbooks.Open "\\... \xyz.xlsm"
End If
1
Set wb_quelle = ThisWorkbook
Set ws_ziel = Workbooks("xyz.xlsm").Worksheets("Auswertung")
Application.ScreenUpdating = False
i = ws_ziel.Range("C10000").End(xlUp).Row + 1
For Each sh In wb_quelle.Worksheets
j = 10
Do While j "" Then
ws_ziel.Range("I" & i).Value = sh.Range("E" & j).Value
ws_ziel.Range("C" & i).Value = sh.Range("D" & j).Value
ws_ziel.Range("B" & i).Value = sh.Range("H" & j).Value
ws_ziel.Range("M" & i).Value = sh.Range("C" & j).Value
Else: GoTo 0
End If
j = j + 5 verbundene Zellen in C Spalte, nach 5 Zeilen geht neuer Block los
i = i + 1
Loop
0
End Select
Next
Application.ScreenUpdating = True
MsgBox ("Datenübertragung erfolgreich")
End Sub