AW: Tabelle verschieben
21.03.2015 16:49:07
fcs
Hallo Schulz,
ich hoffe, dass das Makro mit dem schweizer Zahlenformat klarkommt und dieses als nummerisch erkennt und den Zahlenvergleich korrekt abarbeitet.
Gruß
Franz
Sub Schulz()
'Hilfe bei Herber
Dim wkbAktiv As Workbook
Dim wkbJM As Workbook
Dim wksNeu As Worksheet
Dim Zeile As Long, Zeile_L As Long, StatusCalc As Long
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wkbAktiv = ActiveWorkbook
Set wkbJM = Workbooks.Open( _
Filename:="C:\Users\" & Environ("UserName") & "\Desktop\JM.xls", _
ReadOnly:=True) 'Verzeichnis ggf. anpassen
With wkbAktiv
wkbJM.Worksheets(1).Copy after:=.Sheets(.Sheets.Count)
Set wksNeu = .Sheets(.Sheets.Count)
wkbJM.Close savechanges:=False
End With
With wksNeu
.Rows("5:6").Delete Shift:=xlUp
.Rows("1:3").Delete Shift:=xlUp
.Range("E:N").Delete Shift:=xlToLeft
.Range("A:A").Clear 'Spalte A wird später benutzt, um die Zeilen _
zu markieren, die nicht gelöscht werden sollen
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("B1"), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange wksNeu.Range("A:D")
.Header = xlYes 'oder xlNo - ggf. anpassen
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
For Zeile = 1 To Zeile_L
If IsEmpty(.Cells(Zeile, 2)) Then 'wenn leer nicht löschen
.Cells(Zeile, 1) = "X"
ElseIf .Cells(Zeile, 2) = "" Then 'wenn Leerstring nicht löschen
.Cells(Zeile, 1) = "X"
ElseIf IsNumeric(.Cells(Zeile, 2).Text) Then
'wenn außerhalb des Zahlenbereichs dann nicht löschen
If .Cells(Zeile, 2) 6000000 Then
.Cells(Zeile, 1) = "X"
End If
End If
Next
With .Range(.Cells(1, 1), .Cells(Zeile_L, 1))
'Prüfen, ob im Bereich in Spalte A Leerzellen vorhanden sind
If Application.WorksheetFunction.CountBlank(.Cells) > 0 Then
'Zeilen löschen, die im Bereich leer sind
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete xlShiftUp
End If
'Spalte A löschen
.EntireColumn.Delete Shift:=xlShiftToLeft
End With
End With
With Application
.ScreenUpdating = False
.Calculation = StatusCalc
End With
End Sub