VBA-kopieren
02.06.2019 20:05:09
henry
ich habe 4 worksheets und möchte den Inhalt von 4 Ordnern per Makro in das Worksheet Inhaltsverzeichnis übertragen.
1. Inhalt Inhaltsverzeichnis löschen
2. Eintrage von Ordner 1 bis 4 in Inhaltsverzeichnis eintragen
Ordner 1 bis 2 funktioniert, vom Ordner 3 und 4 werden Zuwenig Zeilen übertragen. Ich komme auf den Fehler nicht drauf und bitte um Korrektur des Makros. -
Freundliche Grüße
Henry
Option Explicit
Sub kopieren()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet, ws5 As _
Worksheet
Dim intZeile As Integer
Set ws1 = Worksheets("Ordner1")
Set ws2 = Worksheets("Ordner2")
Set ws4 = Worksheets("Ordner3")
Set ws5 = Worksheets("Ordner4")
Set ws3 = Worksheets("Inhaltsverzeichnis")
'löschen der Inhaltsverzeichnisdatei
Range("A6:D100").Select
Selection.ClearContents
If ws1.Cells(5, 1).Value "" Then
ws1.Range("A5:D" & ws1.Cells(Rows.Count, 2).End(xlUp).Row).Copy
ws3.Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
If ws2.Cells(5, 1).Value "" Then
ws2.Range("A5:D" & ws2.Cells(Rows.Count, 2).End(xlUp).Row).Copy
ws3.Select
Range("A6").Select
Range("A" & ws3.Cells(Rows.Count, 2).End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
If ws4.Cells(5, 1).Value "" Then
ws4.Range("A5:D" & ws2.Cells(Rows.Count, 2).End(xlUp).Row).Copy
ws3.Select
Range("A6").Select
Range("A" & ws3.Cells(Rows.Count, 2).End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
If ws5.Cells(5, 1).Value "" Then
ws5.Range("A5:D" & ws2.Cells(Rows.Count, 2).End(xlUp).Row).Copy
ws3.Select
Range("A6").Select
Range("A" & ws3.Cells(Rows.Count, 2).End(xlUp).Row + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
Range("A5").Select
End Sub