AW: alle Blätter auf einem zusammenfassen
15.09.2009 20:36:39
Tino
Hallo,
hier mal ein erster Versuch.
Function FindLetzte(mySH As Worksheet) As Range
Dim LRow As Long, LCol As Long
Dim A As Long
With mySH.UsedRange
On Error Resume Next
'Finde Zeile
LRow = .Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False, False).Row
LRow = Application.Max(LRow, .Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
If LRow = 0 Then LRow = 1
'Finde Spalte
For A = .Columns(.Columns.Count).Column To .Columns(1).Column Step -1
LCol = mySH.Columns(A).Find("*", , xlValues, xlWhole, xlByRows, xlPrevious).Row
LCol = Application.Max(LCol, mySH.Columns(A).Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row)
If LCol > 1 Then: LCol = A: Exit For
Next A
If LCol = 0 Then LCol = 1
End With
Set FindLetzte = mySH.Cells(LRow, LCol)
End Function
Sub Zusammen()
Dim meSh As Worksheet
Dim Bereich As Range, rNextFreie As Range
Dim iCalc As Integer
With Application
iCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
'gehe davon aus in Zeile 1 ist Überschrift u. Tabelle ist nicht komplett gefüllt
Sheets("Zusammenfassung").UsedRange.Offset(1, 0).Value = ""
For Each meSh In ThisWorkbook.Worksheets
If meSh.Name Like "Lager*" Then
Set Bereich = meSh.Range("A2", FindLetzte(meSh))
If Intersect(Bereich, meSh.Rows(1)) Is Nothing Then
With Sheets("Zusammenfassung")
Set rNextFreie = .Cells(FindLetzte(Sheets(.Name)).Row + 1, 1)
End With
Bereich.Copy rNextFreie
End If
End If
Next meSh
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Gruß Tino