Laufzeitfehler 9 Excel seit Office update 2010 zu 2016
21.03.2024 11:41:37
sanane3443
Sub FiberCollect()
Dim NumRows As Long 'letzte celle
Dim Counter As Long, i As Long, actualtube As Long, lasttube As Long, StartRow As Long, EndRow As Long, DestinationRow As Long
Dim SheetNumber As Long
Worksheets("Überblicksblatt").Activate
SheetNumber = 0
lasttube = 0
DestinationRow = 20
NumRows = 1
NumRows = ThisWorkbook.Sheets("Überblicksblatt").Range("A2", Range("A2").End(xlDown)).Rows.count
If NumRows > 65536 - 5 Then
NumRows = 1
End If
For Counter = 1 To NumRows
If IsNumeric(ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").Offset(, -2).value) Then
actualtube = ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").Offset(, -2).value
Else
actualtube = ColourSelect(ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").Offset(, -2).text)
End If
If lasttube = actualtube Then
'copy first row last row
StartRow = ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").Row
EndRow = ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").End(xlDown).Row
If EndRow = ThisWorkbook.Sheets(Counter).Range("ParamTableOrigin").Row Then
EndRow = StartRow
End If
For i = StartRow To EndRow
'ThisWorkbook.Sheets(Counter).Rows(i).Copy Destination:=ThisWorkbook.Sheets("Überblicksblatt").Cells(DestinationRow - StartRow + 1 + i, 1)
ThisWorkbook.Sheets(Counter).Rows(i).Copy Destination:=ThisWorkbook.Sheets(SheetNumber).Cells(DestinationRow - StartRow + 1 + i, 1)
Next i
StartRow = 0
EndRow = 0
ThisWorkbook.Sheets("Überblicksblatt").Cells(1 + Counter, 2).value = ""
Else
StartRow = ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").Row
EndRow = ThisWorkbook.Sheets(Counter).Range("AttenTableOrigin").End(xlDown).Row
If EndRow > ThisWorkbook.Sheets(Counter).Range("ParamTableOrigin").Row Then
EndRow = StartRow
End If
DestinationRow = EndRow
SheetNumber = Counter
End If
lasttube = actualtube
Next Counter
End Sub
Anzeige