AW: Geöffnete Tabellenblätter einfügen
21.07.2010 19:01:36
Tino
Hallo,
hier mal eine Version so wie ich Deine Frage verstanden habe.
Es wird eine neue Datei erstellt und alle Tabellen, aus den gerate geöffneten Dateien kopiert.
Danach werden diese Sortiert.
kommt als Code in Modul1
Option Explicit
Dim Regex As Object
Sub Sheets_Copy_And_Sort()
Dim meAr(), i As Integer, ii As Integer
Dim oWB As Workbook, oWBOben As Workbook, oSh As Object
'Schleife über alle Dateien
For Each oWBOben In Workbooks
'Schleife über alle Tabellen in Datei
For Each oSh In oWBOben.Sheetsi
ii = ii + 1
Redim Preserve meAr(1 To 2, 1 To ii) 'Array dimensionieren
If oWB Is Nothing Then 'neue Datei ertsellen
oSh.Copy 'erste Tabelle kopieren
Set oWB = ActiveWorkbook 'diese Datei merken
Else
'neue Datei bereit erstellt, nur kopieren
oSh.Copy After:=oWB.Sheets(oWB.Sheets.Count)
End If
'die kopierte Tabelle
With oWB.Sheets(oWB.Sheets.Count)
'optimale Spaltenbreite
.UsedRange.EntireColumn.AutoFit
'Name der Tabelle
meAr(1, ii) = .Name
'Zahlen aus Tabelle
meAr(2, ii) = Ziffer(.Name) 'Ziffern aus Namen
End With
Next oSh
Next oWBOben
If ii > 0 Then
'Array drehen
meAr = Application.Transpose(meAr)
'Array nach Zahlen sortieren
QuickSort meAr, Lbound(meAr), Ubound(meAr), 2
'Tabellen sortieren
For i = Ubound(meAr) To Lbound(meAr) Step -1
oWB.Sheets(meAr(i, 1)).Move After:=oWB.Sheets(i)
Next i
End If
Set Regex = Nothing
End Sub
'Funktion für Ziffern aus Text
Function Ziffer(ByVal strText$) As Long
Dim objMatch As Object
If Regex Is Nothing Then
Set Regex = CreateObject("Vbscript.Regexp")
With Regex
.Pattern = "\d+"
.Global = True
End With
End If
Set objMatch = Regex.Execute(strText)
strText = ""
If objMatch.Count > 0 Then
For Each objMatch In objMatch
strText = strText & objMatch.Value
Next objMatch
End If
If IsNumeric(strText) Then
Ziffer = CLng(strText)
Else
Ziffer = 0
End If
End Function
kommt als Code in Modul2
Option Explicit
Sub QuickSort(ByRef sArray, ByVal StartUnten As Long, ByVal EndeOben As Long, _
ByVal LCol As Long, Optional ByVal Absteigend As Boolean = False)
Dim iUnten As Long, iOben, iMitte, y
Dim A As Long
iUnten = StartUnten
iOben = EndeOben
iMitte = sArray((StartUnten + EndeOben) / 2, LCol)
While (iUnten <= iOben)
If Not Absteigend Then
While (sArray(iUnten, LCol) < iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte < sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
Else
While (sArray(iUnten, LCol) > iMitte And iUnten < EndeOben)
iUnten = iUnten + 1
Wend
While (iMitte > sArray(iOben, LCol) And iOben > StartUnten)
iOben = iOben - 1
Wend
End If
If (iUnten <= iOben) Then
For A = Lbound(sArray, 2) To Ubound(sArray, 2)
y = sArray(iUnten, A)
sArray(iUnten, A) = sArray(iOben, A)
sArray(iOben, A) = y
Next A
iUnten = iUnten + 1
iOben = iOben - 1
End If
Wend
If (StartUnten < iOben) Then Call QuickSort(sArray, StartUnten, iOben, LCol, Absteigend)
If (iUnten < EndeOben) Then Call QuickSort(sArray, iUnten, EndeOben, LCol, Absteigend)
End Sub
Gruß Tino