AW: Zeilen/Spalten über/Links vom Suchergebn. lösc
27.05.2008 22:42:00
stefan
Hey Sepp
es sind meine Online-Banking Daten mit all meinen Informationen
das möchte ich nicht hochladen - ich hoffe, dass Du das verstehtst
hier das Makro, was bisher funktioniert
wollte den Beginn des Makros vereinfachen, weil die Zelle mit dem Text "Buchungstag" sich regelmässig ändert
Sub Aufbereiten_NEUE_Version()
'
'
'EXCEL XP v 2 Änderung 06/2007
Cells.Select
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Änderung vom 03.04.2008
' Rows("1:486").Select
' Selection.Delete Shift:=xlUp
' Columns("A:G").Select
' Selection.Delete Shift:=xlToLeft
' Columns("B:D").Select
' Selection.Delete Shift:=xlToLeft
' Columns("C:C").Select
' Selection.Delete Shift:=xlToLeft
' Columns("D:E").Select
' Selection.Delete Shift:=xlToLeft
' Columns("E:M").Select
' Selection.Delete Shift:=xlToLeft
'Änderung vom 18.05.2008 / 27.05.2009 493 neu
Rows("1:493").Select
' Range("C493").Activate
Selection.Delete Shift:=xlUp
Columns("A:G").Select
Selection.Delete Shift:=xlToLeft
Columns("B:D").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Selection.Delete Shift:=xlToLeft
Columns("E:H").Select
Selection.Delete Shift:=xlToLeft
'Änderung vom 27.05.2008
'Spalten und Zeilen oberhalb/links nach "Buchungstag" löschen FUNKTIONIERT noch NICHT
'Dim rng As Range
'With ActiveSheet
' Set rng = .Cells.Find(What:="Buchungstag", LookAt:=xlWhole)
' If Not rng Is Nothing Then
' .Range(.Cells(1, 1), .Cells(rng.Row - IIf(rng.Row > 1, 1, 0), rng.Column - IIf(rng.Column > 1, 1, 0))).Delete
' End If
'End With
'
'Set rng = Nothing
'---------------------------------------
For Each objShape In ActiveSheet.Shapes
objShape.Delete
Next
'Application.Run "Kontoumsatz_16.xls!DeleteEmptyRows"
DeleteEmptyRows
'Application.Run "Kontoumsatz_16.xls!zellen_verknüpfen"
zellen_verknüpfen
Range("A1").Select
'Application.Run "Kontoumsatz_16.xls!Umsortieren"
Umsortieren
Range("A1").Select
Columns("B:B").ColumnWidth = 50
Columns("B:B").Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit
Range("A1").Select
End Sub
Private Sub DeleteEmptyRows()
LastRow = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For r = LastRow To 1 Step -1
If Application.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r
End Sub
Private Sub Umsortieren()
Dim LetzteZeile As Integer, intCounter As Integer
LetzteZeile = ActiveSheet.UsedRange.Rows.Count
Columns(1).Insert Shift:=xlToRight
For intCounter = 1 To LetzteZeile
Cells(intCounter, 1) = intCounter
Next intCounter
Selection.Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Columns(1).Delete Shift:=xlToLeft
End Sub
Private Sub zellen_verknüpfen()
Dim i As Integer
i = 2
While Not (IsEmpty(Cells(i, 2)))
If IsEmpty(Cells(i, 1)) Then
Cells(i - 1, 2).Value = Cells(i - 1, 2).Value & vbLf & Cells(i, 2)
Rows(i & ":" & i).Select
Selection.Delete Shift:=xlUp
Cells(i, 2).Select
'MsgBox i
Else
i = i + 1
End If
Wend
End Sub