@ FCS Hilfe bei Codeanpassung
Maris
kann den alten Thread leider nicht öffnen. die Anpassung des Bereichs habe ich hinbekommen... Ist das so richtig (funktioniert wenigsten ;-)!):
Dim arrItems(1 To 24)
If iWeek = "99" Then
arrWeeks = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheets(arrSheets(0)). _
Range("B2:AAA2"))) 'anpassen
Else
arrWeeks = Array(iWeek)
End If
For Each myWeek In arrWeeks
For Each mySheet In arrSheets
With Sheets(mySheet)
lngC = Application.Match(myWeek, .Rows(2), 0)
If Not IsError(lngC) Then
'Kategoriedaten einlesen
For lngRow = 20 To .Cells(Rows.count, 1).End(xlUp).Row Step 17
j = 0
arrTmp = Split(.Cells(lngRow, 1), ">")
j = j + 1: arrItems(j) = myWeek
j = j + 1: arrItems(j) = arrTmp(0) 'Top Level
j = j + 1
If UBound(arrTmp) > 0 Then
arrItems(j) = arrTmp(1) 'Kategorie
End If
j = j + 1: arrItems(j) = .Cells(lngRow, 1) 'Top Level > Kategorie
For i = 1 To 20
Select Case i
Case 1 To 20
j = j + 1: arrItems(j) = .Cells(lngRow + i, lngC)
End Select
Next
oDaten(.Cells(lngRow, 1).Value & "_" & myWeek) = arrItems
Next
End If
End With
Next
Next myWeek
Application.ScreenUpdating = False
With Sheets("TotalsRaw")
If iWeek = "99" Then
If .Cells(.Rows.count, 1).End(xlUp).Row > 1 Then
.Range(.Cells(2, 1), .Cells(.Rows.count, 1).End(xlUp)).EntireRow.ClearContents
End If
If oDaten.count > 0 Then
.Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(oDaten.count, 20) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items))
'KW und Jahr in 2 Spalten aufteilen - für Sortierungen und anderes
With .Range(.Cells(2, 1), .Cells(.Rows.count, 1).End(xlUp))
' .TextToColumns Destination:=Range("Q2"), DataType:=xlDelimited, _
other:=True, otherchar:="/"
End With
End If
Else
If oDaten.count > 0 Then
lngRow = .Cells(Rows.count, 1).End(xlUp).Row + 1
.Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(oDaten.count, 20) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items))
'KW und Jahr in 2 Spalten aufteilen - für Sortierungen und anderes
With .Range(.Cells(lngRow, 1), .Cells(.Rows.count, 1).End(xlUp))
' .TextToColumns Destination:=Range("Q2"), DataType:=xlDelimited, _
other:=True, otherchar:="/"
End With
End If
End If
End With
Application.ScreenUpdating = True
End Sub
Kannst du mir noch kurz diese Frage beantworten?https://www.herber.de/forum/archiv/1224to1228/t1225515.htm#1226250
Danke und Viele Grüsse,
Maris