Kopierschleife

Ich habe eine Excel-Arbeitsworkbook vorliegen mit 20 Worksheets. Im Worksheet Nummer 3 stehen in der Spalte G Namen und in der Spalte J Werte. Der Aufbau der Worksheets ist von Worksheet 3 bis Worksheet 15 identisch. Nun möchte ich überprüfen, bis zu welcher Zeile in G ein Inhalt enthalten ist und bis zu dieser Zeilennummer die Werte aus J Kopieren und an selbiger Stelle fortlaufend in die Worksheets 4 bis 15 einfügen. Also J10 in Worksheet 3 zu J10 in Worksheet 4, Worksheet 5 usw.
Beispiel:
G10 Max Mustermann ........................ J10 555
G11 Petra Musterfrau ........................ J11 777
G12 Herr Basic ........................ J12 999
G13 Frau Excel ........................ J13 333
Folglich sollen die Werte in diesem Beispiel 555, 777, 999 und 333 kopiert und an selbiger stelle in die folgenden 11 Worksheets (Worksheet 4 bis 15) eingefügt werden.
Weiß jemand, wie man diese Ablauflogik mit einer Schleife realisieren kann?
Derzeit weise ich die zu kopierenden Werte mit einer Copy_To Destination:= an die entsprechende Stelle zu. Dies ist jedoch sehr ineffizient, da es in meinem obigen Beispiel nur viert Werte (da vier Namen in G) sind, jedoch es durchaus auch 50 oder mehr Namen in G und damit verbundene Werte in J sein können.
Ich habe mir schon meine Gedanken gemacht, doch weiß nicht, wie ich den Kopiervorgang programmieren soll:
Sub KopierBefehl()
Dim i As Integer
i = 1
Do While Not Cells(G7) = "" Überprüft bis in welche Zeile in G ein Name Steht
j = Sheets.Count
For i = 4 To 15 Legt die Worksheets für die Kopien fest
Hier müsste die Kopieranweisung rein, also: J10 zu J10 in Worksheet 4, zu Worksheet 5, zu Worksheet 6 usw.
Next i
Ich hoffe, dass jemand Rat weiß.
Vielen Dank!
Beste Grüße,
Norbert

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets(3) Dim c As Range, i& With WsQ For Each c In .Range("J1:J" & .Cells(.Rows.Count, "J").End(xlUp).Row) For i = 4 To 15 Wb.Worksheets(i).Cells(c.Row, c.Column) = c.Value Next i Next c End With Set Wb = Nothing: Set WsQ = Nothing: Set c = Nothing End Sub

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets(3) Dim c As Range, i& With WsQ For Each c In .Range("G1:G" & .Cells(.Rows.Count, "J").End(xlUp).Row) For i = 4 To 15 Wb.Worksheets(i).Cells(c.Row, c.Column+3) = c.OffSet(,3).Value Next i Next c End With Set Wb = Nothing: Set WsQ = Nothing: Set c = Nothing End Sub

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets(3) Dim c As Range, i& With WsQ For Each c In .Range("G1:G" & .Cells(.Rows.Count, "G").End(xlUp).Row) For i = 4 To 15 Wb.Worksheets(i).Cells(c.Row, c.Column+3) = c.OffSet(,3).Value Next i Next c End With Set Wb = Nothing: Set WsQ = Nothing: Set c = Nothing End Sub

Hallo,
ich habe mal ein Workbook erstellt, welches genau so wie das Workbook aussieht, in welchem das Makro implementiert werden soll.
Aus jeder Monatsspalte in Worksheet 3 sollen die Werte Analog in die folgenden Worksheets übertragen werden. Also Inhalt aus J2:6 aus Worksheet Januar, nach J2:6 in Worksheet Februar, März, April usw.
Die freien Zellen in der entsprechenden Spalte (in dem keine Werte mehr drunterstehen) sollen aber nicht mit 0 aufgefüllt werden, da hier Formeln hinterliegen.
Zusammengefasst: Zu kopierende Spalten J, L, N, P, R, T, V, X, Z, AB, AD an die entsprechende Stelle in den folgenden Worksheets.
Ich hatte in meinem ersten Beitrag nur eine Spalte genannt, da ich dachte, ich könnte es selbst anpassen. Habe ich doch leider auch nicht geschafft..
Mappe:
https://www.herber.de/bbs/user/116874.xlsx
Grüße,
Norbert

Sub a() Dim Wb As Workbook: Set Wb = ThisWorkbook Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Januar") Dim i&, j&, lR&, c Application.ScreenUpdating = False c = Array("J", "L", "N", "P", "R", "T", "V", "X", "Z", "AB", "AD") With WsQ lR = .Cells(.Rows.Count, "G").End(xlUp).Row For i = LBound(c) To UBound(c) .Range(.Cells(2, c(i)), .Cells(lR, c(i))).Copy For j = 4 To 14 With Wb.Worksheets(j) .Cells(2, c(i)).PasteSpecial xlPasteValues End With Next j Next i End With Set Wb = Nothing: Set WsQ = Nothing: Erase c End Sub

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread