Laufzeitfehler 1004
29.06.2020 13:37:29
and2handles
ich habe mir nen VBA Code zusammengebastelt und kopiert der eigentlich sehr gut funktioniert und ich habe ihn mit weiteren Funktionen erweitert.
Leider funktioniert der folgende Part nicht:
Sheets("AlleDaten").Select
Columns("A:A").Select
Range("A200").Activate
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
Wenn ich den Code einzeln laufen lasse funktioniert er einwandfrei aber wenn ich ihn mit dem restlichen Code laufen lasse bekomme ich einen Laufzeitfehler 1004. Hat jemand eine Ahnung woran das liegen kann?
Unten der Gesamtcode.
'Fügt Datenblätter zusammen
Sub AlleDaten()
' Einfügen erste Zelle table1
Sheets("page 1").Select
Range("A1").Select
ActiveCell.FormulaR1C1 = "Schlag/Zyklus"
Selection.AutoFill Destination:=Range("A1:G1"), Type:=xlFillDefault
Range("A1:G1").Select
'Es werden die Daten aller Tabellenblätter innerhalb einer Datei auf einem neuen Tabellenblatt gelistet.
'Die Tabellenblätter haben eine Überschrift in Zeile 1 ab A1, die Daten stehen ab Zeile 2
'Die Tabellenblätter haben einen identischen Aufbau ( Anzahl Spalten ). Die Anzahl der Zeilen spielt keine Rolle.
'Ein Tabellenblatt mit dem Namen "AlleDaten" wird, wenn nicht bereits vorhanden, ganz links erstellt.
Dim wks As Worksheet 'Tabelle AlleDaten
Dim intSh As Integer 'Zähler für Tabelle1 bis TabelleX
Dim intLastS As Integer 'Letzte benutzte Spalte in den Tabellen
Dim bln As Boolean
'Prüfung ob Blatt "AlleDaten" bereits vorhanden ist.
For intSh = 1 To ActiveWorkbook.Worksheets.Count
If Worksheets(intSh).Name = "AlleDaten" Then
Set wks = Worksheets("AlleDaten")
bln = True
Exit For
End If
Next
'Falls nicht vorhanden dann erstellen
If bln = False Then
Set wks = Worksheets.Add
wks.Name = "AlleDaten"
End If
'Blatt AlleDaten nach links schieben
wks.Move Before:=Sheets(1)
'Daten auf Blatt "AlleDaten" löschen und die Überschrift aus Tabelle1 holen
'Anzahl der Spalten zählen. Gilt dann für alle Blätter da Aufbau identisch sein muss
wks.Cells.ClearContents
Worksheets(2).Rows(1).Copy Destination:=wks.Range("A1")
intLastS = wks.Cells(1, Columns.Count).End(xlToLeft).Column
'Daten aus allen Tabellen nach Tabelle "AlleDaten" übertragen
For intSh = 2 To ActiveWorkbook.Worksheets.Count
With Worksheets(intSh)
'Zellübertragung
.Range(.Cells(8, 1), .Cells(fncLastRow(intSh, intLastS), intLastS)).Copy
wks.Cells(wks.UsedRange.Rows.Count, 1).Offset(1, 0).PasteSpecial Paste:=xlValues
End With
Next
Application.CutCopyMode = False
'bereinigt pseude-leere Zellen im aktiven Tabellenblatt
Dim Zelle As Range, StatusCalc As Long
If ActiveSheet.Type = xlWorksheet Then
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
For Each Zelle In ActiveSheet.UsedRange.Cells
If Not Zelle.HasFormula Then
If Not IsEmpty(Zelle) And Zelle.Value = "" Then
Zelle.ClearContents
End If
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End If
Sheets("AlleDaten").Select
Columns("A:A").Select
Range("A200").Activate
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Sub
Public Function fncLastRow(ByVal intSh As Integer, intLastS As Integer) As Long
Dim intS As Integer
With Worksheets(intSh)
For intS = 1 To intLastS
If .Cells(Rows.Count, intS).End(xlUp).Row > fncLastRow Then
fncLastRow = .Cells(Rows.Count, intS).End(xlUp).Row
End If
Next
End With
End Function