Leere Zeilen Löschen!
08.12.2015 16:28:13
John
So, nächste Problem das ich scheinbar nicht lösen kann!
Per Makro werden mir die Daten in ein neues .sheet kopiert, das funktioniert auch ganz gut! Nun werden die leeren Zeilen mit angehängt und die Stören bei der berechnung :(
Da ja in dem fall die spalte A leer ist, habe ich es erfolglos mit
If Application.CountA(.Cells(Lrow, 1).Range("A1")) = 0 Then .Rows(Lrow).Delete
und weiteren verückten sachen versucht, komme aber leider nicht weiter!
Public Sub kilometer()
Worksheets("Kilometer").Cells.Clear
With Application
.ScreenUpdating = False
.Application.AskToUpdateLinks = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
Dim lRow As Long
Dim sh As Worksheet
Dim shArc As Worksheet
Set shArc = ThisWorkbook.Worksheets("Kilometer")
For Each sh In ThisWorkbook.Worksheets
Select Case sh.Name
Case Is <> "Kilometer"
If Left(sh.Name, 2) = "RE" Then
lRow = shArc.Range("A" & Rows.Count).End(xlUp).Row + 1
If lRow = 2 Then lRow = 1
sh.Range("A24:H51").Copy
shArc.Range("A" & lRow).PasteSpecial xlPasteValues
shArc.Range("A" & lRow).PasteSpecial xlPasteFormats
End If
End Select
Next
Application.CutCopyMode = False
Set shArc = Nothing
Set sh = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
Sheets(1).Activate
End With
End Sub
Wie zum Weinachtsmann kann ich die Zeilen löschen?
Da die leeren Zeilen von A kein Datum enthalten möchte ich diese gerne löschen!
Einer meiner versuche war auch
Public Sub kilometer()
Worksheets("Kilometer").Cells.Clear
With Application
.ScreenUpdating = False
.Application.AskToUpdateLinks = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
Dim lRow As Long
Dim sh As Worksheet
Dim shArc As Worksheet
Set shArc = ThisWorkbook.Worksheets("Kilometer")
For Each sh In ThisWorkbook.Worksheets
Select Case sh.Name
Case Is <> "Kilometer"
If Left(sh.Name, 2) = "RE" Then
lRow = shArc.Range("A" & Rows.Count).End(xlUp).Row + 1
If lRow = 2 Then lRow = 1
sh.Range("A24:H51").Copy
shArc.Range("A" & lRow).PasteSpecial xlPasteValues
shArc.Range("A" & lRow).PasteSpecial xlPasteFormats
End If
End Select
Next
Application.CutCopyMode = False
On Error Resume Next
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Set shArc = Nothing
Set sh = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
Sheets(1).Activate
End With
End Sub
da werden mir aber die falschen Zeilen im falschen .sheet gelöscht!
Grüsse John
Anzeige