AW: nun ....
27.03.2015 09:41:59
Tim
Hallo Werner,
das Problem ist, dass immer wieder neue Tabellenblätter dazukommen. Deswegen kann ich keine Formeln benutzen.
Mein momentanes Makro:
Sub Makro1()
Application.ScreenUpdating = False
Sheets("Gesamt").Select
ActiveWindow.SelectedSheets.Delete
Dim i As Long
Const Fo As String = "=SumIf('xxx'!A:A,A1,'xxx'!I:I)"
Worksheets.Add before:=Sheets(1)
For i = 2 To Worksheets.Count
Worksheets(i).UsedRange.Columns(1).Copy
Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
Next
Worksheets(1).Rows(1).Delete
Worksheets(1).Columns(1).RemoveDuplicates 1, xlNo
With Worksheets(1)
With .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
For i = 2 To Worksheets.Count
.Offset(0, 2).Formula = Replace(Fo, "xxx", Worksheets(i).Name)
.Offset(0, 2).Copy
.Offset(0, 1).PasteSpecial xlPasteValues, operation:=xlAdd
.Offset(0, 2).ClearContents
Next
End With
End With
Worksheets(1).Cells(1, 2).Value = "Menge"
Worksheets(1).Name = "Gesamt"
Columns("A:A").Select
ActiveWorkbook.Worksheets("Gesamt").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Gesamt").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Gesamt").Sort
.SetRange Range("A2:B155")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim intRow As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If IsEmpty(Cells(intRow, 1)) Then
Rows(intRow).Delete
End If
Next intRow
Application.ScreenUpdating = True
End Sub