Hilfe bei Codeanpassung
Maris
mit folgendem Code habe ich immer Daten von 2 Tabs in ein Üebrsichtstab kopiert. Kriterium war die Kalender Woche in einer Zahl... also z.B. 26. Ich habe jetzt das Format geändert, da ich diese Tabelle fortlaufend mit Daten befüllen möchte, habe ich das Format um die Jahreszahl ergänzt, also 26/2011. Meine Tabelle hat auch diese Überschriften bekommen allerding funktioniert der Code jetzt nicht mehr.
Hier der alte Code:
Option Explicit
Sub prcStart()
Dim iWeek
iWeek = Application.InputBox("Week?" & vbLf & "99 for all Weeks", "Eingabe", , , , , , 1)
Select Case iWeek
Case False
Case 1 To 53, 99: prcDaten iWeek
End Select
End Sub
Sub prcDaten(ByVal iWeek As Integer)
Dim oDaten As Object, lngRow As Long, lngC, arrSheets, mySheet
Dim arrItems(1 To 20), arrWeeks, myWeek, arrTmp, i As Integer
Set oDaten = CreateObject("Scripting.Dictionary")
arrSheets = Array("Auto", "Motorräder") 'nach Bedarf erweitern
If iWeek = 99 Then
arrWeeks = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheets(arrSheets(0)). _
Range("B2:BA2"))) '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
For lngRow = 20 To .Cells(Rows.count, 1).End(xlUp).Row Step 17
arrTmp = Split(.Cells(lngRow, 1), ">")
arrItems(1) = myWeek
arrItems(2) = arrTmp(0)
If UBound(arrTmp) > 0 Then
arrItems(3) = arrTmp(1)
End If
arrItems(4) = .Cells(lngRow, 1)
For i = 5 To 20
arrItems(i) = .Cells(lngRow + i - 4, lngC)
Next
oDaten(.Cells(lngRow, 1).Value & "_" & myWeek) = arrItems
Next
End If
End With
Next
Next myWeek
If oDaten.count > 0 Then
Application.ScreenUpdating = False
With Sheets("TotalsRaw")
.Cells(Rows.count, 1).End(xlUp).Offset(1).Resize(oDaten.count, 20) = _
WorksheetFunction.Transpose(WorksheetFunction.Transpose(oDaten.items))
End With
End If
End Sub
Beipieltabelle:https://www.herber.de/bbs/user/76097.xls
Vielen lieben Dank schon mal im voraus!!!
Grüsse,
Maris