AW: Werte lesen und in andere Tabelle übertragen
21.04.2017 14:26:15
Bernd
Servus,
für den Aufwand sollte ich Lizenzgebühren verlangen :-)
Sub kopieren()
Dim wb As Workbook
Dim wb2 As Workbook
Dim ws As Worksheet
Dim ws2 As Worksheet
Set wb = ThisWorkbook
Set wb2 = Workbooks.Open("C:\Test\Microsoft Excel-Arbeitsblatt (neu).xlsx") ' Pfad der _
Zieldatei anpassen
Set ws = wb.Sheets("Tabelle1") ' Tabellennamen anpassen
Set ws2 = wb2.Sheets("Tabelle1") ' Tabellennamen anpassen
intLZ = ws.Cells(Rows.Count, 1).End(xlUp).Row
x = 0
y = 0
For i = 2 To intLZ
ws2.Cells((5 + x * 8), (1 + y * 4)).Value = ws.Cells(i, "A").Value ' von A1 nach A5
ws2.Cells((5 + x * 8), (2 + y * 4)).Value = ws.Cells(i, "B").Value ' von B1 nach B5
ws2.Cells((2 + x * 8), (3 + y * 4)).Value = ws.Cells(i, "G").Value ' von G1 nach C2
ws2.Cells((3 + x * 8), (3 + y * 4)).Value = ws.Cells(i, "H").Value ' von H1 nach C3
ws2.Cells((2 + x * 8), (2 + y * 4)).Value = ws.Cells(i, "I").Value ' von I1 nach B2
ws2.Cells((3 + x * 8), (2 + y * 4)).Value = ws.Cells(i, "J").Value ' von J1 nach B3
ws2.Cells((2 + x * 8), (1 + y * 4)).Value = ws.Cells(i, "K").Value ' von K1 nach A2
ws2.Cells((7 + x * 8), (2 + y * 4)).Value = ws.Cells(i, "M").Value ' von M1 nach B7
ws2.Cells((7 + x * 8), (1 + y * 4)).Value = ws.Cells(i, "N").Value ' von N1 nach A7
x = x + 1
If x = 3 Then
y = y + 1
x = 0
End If
Select Case i
Case Is = 10, 19, 28, 37, 46, intLZ
ws2.PrintOut , copies:=1
ws2.Range("A2:K3").ClearContents
ws2.Range("A5:K5").ClearContents
ws2.Range("A7:K7").ClearContents
ws2.Range("A10:K11").ClearContents
ws2.Range("A13:K13").ClearContents
ws2.Range("A15:K15").ClearContents
ws2.Range("A18:K19").ClearContents
ws2.Range("A21:K21").ClearContents
ws2.Range("A23:K23").ClearContents
y = 0
End Select
Next i
wb2.Close True
Set ws = Nothing
Set ws2 = Nothing
Set wb = Nothing
Set wb2 = Nothing
End Sub
Grüße, Bernd