AW: Liste auf bestimmte Arbeitsblätter aufteilen
30.06.2010 08:39:26
Tino
Hallo,
kannst diese Version mal testen.
kommt als Code in Modul1
Option Explicit
Enum Up_Or_Down_
iDown = 1
iUp = 2
End Enum
Sub Events_On(booOn As Boolean)
With Application
.ScreenUpdating = booOn
.EnableEvents = booOn
.DisplayAlerts = booOn
End With
End Sub
Function Check_Tab_In_WB(oWB As Workbook, strTabName$) As Boolean
On Error Resume Next
Check_Tab_In_WB = oWB.Sheets(strTabName).Index > 0
End Function
Function FindZelle(rngSuchBereich As Range, strSuchWert, Up_Or_Down As Up_Or_Down_) As Range
Set FindZelle = _
rngSuchBereich.Find(What:="Gruppe 10", LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=Up_Or_Down, _
MatchCase:=True, SearchFormat:=False)
End Function
Sub Test()
Dim rngOrdnung As Range, rngErste As Range, rngLetzte As Range
Dim rngSuchBereich As Range
Dim oSHtmp As Worksheet
Dim oWBEx As Workbook
With Tabelle2
Set rngOrdnung = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 6)
End With
Events_On False
'Tabelle kopieren, damit Formeln nicht zerstört werden
Tabelle1.Copy Before:=Sheets(2)
Set oSHtmp = ActiveSheet
With oSHtmp
'Formel durch Werte ersetzen
.UsedRange.Value = .UsedRange.Value
'Sortiren nach Spalte F
.UsedRange.Sort Key1:=.Cells(1, 6), Order1:=xlAscending, Header:=xlYes
'Suchbereich für erste und letzte Zelle
Set rngSuchBereich = .Columns(6)
'Schleife über alle Zeilen
For Each rngOrdnung In rngOrdnung.Rows
Set rngErste = FindZelle(rngSuchBereich, rngOrdnung.Cells(1, 1), iDown)
'erste Zelle gefunden?
If Not rngErste Is Nothing Then
Set rngErste = rngErste.Offset(0, -5)
Set rngLetzte = FindZelle(rngSuchBereich, rngOrdnung.Cells(1, 1), iUp)
'letzte Zelle gefunden?
If Not rngLetzte Is Nothing Then
On Error Resume Next
Set oWBEx = Workbooks.Open(rngOrdnung.Cells(1, 4) & rngOrdnung.Cells(1, 3))
On Error GoTo 0
If Not oWBEx Is Nothing Then 'Datei geöffnet?
'Prüfe ob Tabelle vorhanden
If Check_Tab_In_WB(oWBEx, CStr(rngOrdnung.Cells(1, 6))) Then
With oWBEx.Worksheets(CStr(rngOrdnung.Cells(1, 6)))
'Bereich kopieren
Range(rngErste, rngLetzte).Copy .Range(rngOrdnung.Cells(1, 5))
'Bereich sortieren nach Spalte A
With .Range(rngOrdnung.Cells(1, 5)).Resize(rngLetzte.Row - rngErste.Row, 6)
.Cells.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo
End With
End With 'oWBEx.Worksheets ...
'Datei schließen mit speichern
oWBEx.Close True
Else
'Tabelle nicht vorhanden, schließen ohne speichern
oWBEx.Close False
End If 'Check_Tab_In_WB
End If 'oWBEx
End If 'rngLetzte
End If 'rngErste
Set rngErste = Nothing: Set rngLetzte = Nothing: Set oWBEx = Nothing
Next rngOrdnung
'Temp Tabelle löschen
.Delete
End With
Events_On True
Set rngSuchBereich = Nothing
End Sub
Gruß Tino