Liste kopieren und mehrmals übeinander einfügen

Hallo Excel Experten,
ich bitte um eure Hilfe bei der Lösung meines Problems.
In Spalte B stehen die Namen A bis K usw. untereinander, wobei es vorkommt, dass einige Zellen zwischen drin leer sind.
In der Spalte A steht neben einigen Namen eine Markierung zB. ein x oder y oder irgend etwas.
In Spalte C und E Stehen jeweils dia Zahlen von 1 bis 52, welche die Kalenderwochen darstellen sollen.
1. Im ersten Schritt sollen alle Namen aus B:B, die eine Markierung in der Spalte A haben, Kopiert werden.
2. Die kopierten Namen sollen nun zunächst in Spalte D in der gleichen Reienfolge wie in Spalte B, also unsortiert, untereinander so oft kopiert werden, bis die KW 52 erreich ist.
Danach soll die Liste in der Spalte F fortgesetzt werden, bis wiederum die 52. KW erreicht wurde.
Vielen Dank für eure Mühe.
Norbert aus Rostock
https://www.herber.de/bbs/user/109729.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Base 1 Sub KWs_Und_Namen_erstellen() Dim Lastcell As Long, Lastcolumn As Long, r As Long, x As Long, MaxKws As Long, KW As Long ReDim A(1) r = 3 c = 3 With ThisWorkbook.Worksheets("Tabelle1") ' Hier bitte Tabellen Name anpassen Lastcell = .Cells(.Rows.Count, 1).End(xlUp).Row Lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column ' Namen mit x in Array(A) laden For r = r To Lastcell If Cells(r, 1) = "x" Then x = x + 1 ReDim Preserve A(x) A(x) = Cells(r, 2) End If Next 'Schleife der Jahre For c = c To Lastcolumn Step 2 MaxKws = AnzWo(.Cells(1, c).Value) 'Anzahl an Kws in dem Jahr ermitteln For KW = 1 To MaxKws If y = UBound(A, 1) Then y = 0 y = y + 1 .Cells(KW + 2, c) = KW .Cells(KW + 2, c + 1) = A(y) Next Next End With End Sub Function AnzWo(Jahr As Integer) 'Anzahl an Kws in dem Jahr ermitteln Function Dim DieWochen As Integer, i As Integer For i = 31 To 28 Step -1 DieWochen = (4 + DateSerial(Jahr, 12, i) - Weekday(DateSerial(Jahr, 12, i), 2) - _ DateSerial(Year(4 + DateSerial(Jahr, 12, i) - Weekday(DateSerial(Jahr, 12, i), 2)), 1, -6)) \ 7 If DieWochen > 1 Then Exit For Next AnzWo = DieWochen End Function

Hey Norbert Guck ma So
Gruß Basti

Option Base 1
Sub KWs_Und_Namen_erstellen()
Dim Lastcell As Long, Lastcolumn As Long, r As Long, x As Long, MaxKws As Long, KW As Long
Dim NewS As Worksheet
ReDim A(1)
r = 3
cc = 1
Set NewS = ThisWorkbook.Worksheets("Tabelle2")
NewS.Cells.ClearContents
With ThisWorkbook.Worksheets("Tabelle1") ' Hier bitte Tabellen Name anpassen
Lastcell = .Cells(.Rows.Count, 1).End(xlUp).Row
Lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
' Namen mit x in Array(A) laden
For r = r To Lastcell
If .Cells(r, 1) = "x" And .Cells(r, 2)  vbNullString Then
x = x + 1
ReDim Preserve A(x)
A(x) = .Cells(r, 2)
End If
Next
'Schleife der Jahre
For c = .Cells(2, 3) To .Cells(2, 4)
NewS.Cells(1, cc) = c
NewS.Cells(2, cc) = "KWs"
NewS.Cells(2, cc + 1) = "Namen"
MaxKws = AnzWo(CStr(c))
'Anzahl an Kws in dem Jahr ermitteln
For KW = 1 To MaxKws
If y = UBound(A, 1) Then y = 0
y = y + 1
NewS.Cells(KW + 2, cc) = KW
NewS.Cells(KW + 2, cc + 1) = A(y)
Next
cc = cc + 2
Next
End With
End Sub
Function AnzWo(Jahr As Integer) 'Anzahl an Kws in dem Jahr ermitteln Function
Dim DieWochen As Integer, i As Integer
For i = 31 To 28 Step -1
DieWochen = (4 + DateSerial(Jahr, 12, i) - Weekday(DateSerial(Jahr, 12, i), 2) - _
DateSerial(Year(4 + DateSerial(Jahr, 12, i) - Weekday(DateSerial(Jahr, 12, i), 2)), 1, -6)) \ 7
If DieWochen > 1 Then Exit For
Next
AnzWo = DieWochen
End Function

Option Base 1 Sub KWs_Und_Namen_erstellen() Dim Lastcell As Long, Lastcolumn As Long, r As Long, x As Long, MaxKws As Long, KW As Long Dim NewS As Worksheet ReDim A(1) r = 3 cc = 1 Set NewS = ThisWorkbook.Worksheets("Tabelle2") NewS.Cells.ClearContents With ThisWorkbook.Worksheets("Tabelle1") ' Hier bitte Tabellen Name anpassen Lastcell = .Cells(.Rows.Count, 1).End(xlUp).Row Lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column ' Namen mit x in Array(A) laden For r = r To Lastcell If .Cells(r, 1) = "x" And .Cells(r, 2) vbNullString Then x = x + 1 ReDim Preserve A(x) A(x) = .Cells(r, 2) End If Next 'Schleife der Jahre For c = .Cells(2, 3) To .Cells(2, 4) NewS.Cells(1, cc) = c NewS.Cells(2, cc) = "KWs" NewS.Cells(2, cc + 4) = "Namen" MaxKws = AnzWo(CStr(c)) 'Anzahl an Kws in dem Jahr ermitteln For KW = 1 To MaxKws If y = UBound(A, 1) Then y = 0 y = y + 1 NewS.Cells(KW + 2, cc) = KW NewS.Cells(KW + 2, cc + 4) = A(y) Next cc = cc + 6 Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Liste kopieren und mehrmals übeinander einfügen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

348 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Liste kopieren und mehrmals übeinander einfügen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

348 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread