Makro kopiert Daten nicht
24.05.2014 20:34:49
Christian
habe ein Problem mit unten stehendem Makro. Bitte helft mir.
Es hat die ganze Zeit funktioniert, habe auch nichts daran geändert, nur die Tabelle4 wurde durch mehrfachem Ausführen immer größer (inzwischen 29526 Zeilen, 5 Spalten).
Wenn ich es jetzt erneut ausführen möchte, bekomme ich Laufzeitfehler '1004': Anwendungs- oder objektdefinierter Fehler und die Stelle im Makro
.Range(.Cells(1, 1), .Cells(lngletzte, 1)).Copy _
Worksheets("Tabelle4").Cells(lngLetzte2 + 1, 1)
Kann mir da jemand helfen, dass 300.000 Zeilen, soviel werden es vermutlich, wenn die Tabelle mal fertig ist, kein Problem darstellen?
Vielen Dank
Christian
Hier noch das ganze Makro.
Sub Makro1()
' Makro1 Makro
' Tastenkombination: Strg+i
Dim lngletzte As Long
Dim lngLetzte2 As Long
Dim lngIndex As Long
Dim vntArray As Variant
Dim strText As String
BilderRaus
With ActiveWorkbook.Worksheets("Tabelle1")
.Range("A:A,C:D").Delete Shift:=xlToLeft
With .Columns("A:A")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
lngletzte = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
If Application.CountA(Worksheets("Tabelle4").Cells) = 0 Then
lngLetzte2 = 1
Else
lngLetzte2 = Worksheets("Tabelle4").Cells.Find(What:="*", _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
End If
.Range(.Cells(1, 1), .Cells(lngletzte, 1)).Copy _
Worksheets("Tabelle4").Cells(lngLetzte2 + 1, 1)
.Columns(1).Clear
End With
With ActiveWorkbook.Worksheets("Tabelle4")
With .Range(.Cells(lngLetzte2 + 1, 2), _
.Cells(.Cells(.Cells.Rows.Count, 1).End(xlUp).Row, 2)).Font
.Name = "Calibri"
.Size = 11
End With
strText = InputBox("Text für Spalte B:", "Eingabe", "Hier der Text")
If Not strText = vbNullString Then
.Range(.Cells(lngLetzte2 + 1, 2), _
.Cells(.Cells(.Cells.Rows.Count, 1).End(xlUp).Row, 2)) = strText
End If
lngLetzte2 = .Cells.Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
.Range(.Cells(1, 5), .Cells(lngLetzte2, 1)).Sort Key1:=.Range("A1:E1"), _
Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Columns("A:A").EntireColumn.AutoFit
.Columns("B:B").EntireColumn.AutoFit
End With
HyperlinkAdressaenderung
End Sub