Variable Tabellenblätter verschieben

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox
Bild

Betrifft: Variable Tabellenblätter verschieben
von: Christina
Geschrieben am: 06.10.2015 11:10:09

Hallo zusammen,
ich benötige bitte Hilfe bei folgendem Problem:
Ich erstelle eine Excel-Datei mit diversen Tabellenblättern, die jeweils mit einer dreistelligen Zahl beschriftet sind, bspw. 101,102,103...838,839
Ich möchte nun immer alle Tabellenblätter, die die gleiche Anfangsziffer haben, in eine neue Datei verschieben.
Also - alle mit "1" vorne in eine Datei, alle mit "2" vorne in eine Datei usw.
Mit Sheets(Array(..)).select habe ich es probiert. Aber das funktioniert nicht, weil nicht jeden Monat die gleichen Blätter vorhanden sind - und ich so das Makro jeden Monat doch wieder anfassen musste.
Vielen Dank im Voraus!
Viele Grüße,
Christina

Bild

Betrifft: AW: Eine Möglichkeit...
von: Michael (migre)
Geschrieben am: 06.10.2015 13:20:51
Hallo Christina,
ist bspw. dies hier:

Sub a()
    Dim Blatt As Worksheet
    Dim ArrNamen() As Variant
    Dim Zaehler As Byte
    Dim Pre As String
    ReDim ArrNamen(1 To Worksheets.Count)
    
    Pre = InputBox("Verschieben von Blättern beginnend mit:", _
            "Blätter verschieben")
    Select Case True
        Case Pre Like "[1-9]"
            For Each Blatt In Worksheets
                If Left(Blatt.Name, 1) = Pre Then
                    Zaehler = Zaehler + 1
                    ArrNamen(Zaehler) = Blatt.Name
                End If
            Next
        Case Else
            MsgBox "Nur Ziffern von 1-9 erlaubt. Abbruch!", _
                vbInformation, "Falsche Eingabe"
            Exit Sub
    End Select
    
    ReDim Preserve ArrNamen(1 To Zaehler)
    Sheets(ArrNamen).Move
End Sub
LG
Michael

Bild

Betrifft: AW: Eine Möglichkeit...
von: Christina
Geschrieben am: 06.10.2015 13:50:18
Hallo Michael,
danke für den Ansatz - leider stoppt er bei mir beim Punkt "ArrNamen(Zaehler) = Blatt.Name".
Vielleicht liegt es daran, dass ich die einzelnen Tabellenblätter wie folgt erzeugt habe?
' Blatt aufteilen
Dim Zelle1 As Range
Dim Zelle2 As Range
Dim shQuelle As Worksheet
Set shQuelle = ActiveSheet
With shQuelle.UsedRange
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
Set Zelle1 = .Cells(2, 1)
Do Until Zelle1 = ""
Set Zelle2 = Zelle1.EntireColumn.Find(What:=Zelle1.Value, LookAt:=xlWhole, _
SearchDirection:=xlPrevious)
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = Zelle1.Value
.Rows(1).Copy ActiveSheet.Cells(1, 1)
Range(Zelle1, Zelle2).EntireRow.Copy ActiveSheet.Cells(2, 1)
Set Zelle1 = Zelle2.Offset(1, 0)
Loop
End With
Wäre super, wenn Du das mit einbeziehen könntest.
Lieben Dank im Voraus.
Viele Grüße,
Christina

Bild

Betrifft: AW: Das kann ich so nicht nachvollziehen...
von: Michael (migre)
Geschrieben am: 06.10.2015 14:00:55
Christina,
denn unabhängig davon, wie Du Deine Tabellenblätter benennst, sammelt mein Code einfach Blattnamen in einem Array, wenn deren erstes Zeichen jenem in der Abfrage (bei mir "Pre") entspricht.
Ich bin von Blattnamen ausgegangen, wie Du sie in Deinem Ausgangsbeitrag angegeben hast: bspw. 101, 102, 103, 504, 838 oder 839.
Hast Du meinen Code einmal autark laufen lassen? Oder hast Du diesen in Deinen Code eingebaut?
Wie gesagt, unter den angegebenen Bedingungen, läuft dies bei mir problemlos (soll heißen: bei Eingabe von zB "1" in der Inputbox werden Tabellenblätter 101, 102, 103... in eine neue Mappe verschoben).
LG
Michael

Bild

Betrifft: AW: eine andere Möglichkeit
von: Daniel
Geschrieben am: 06.10.2015 13:40:45
Hi
probiers mal so:

Sub SheetsNachNameInNeueDateien()
Dim wb(9) As Workbook
Dim sh As Worksheet
Dim i As Long
'--- Blätter in Workbooks aufteilen
For Each sh In ThisWorkbook.Worksheets
    If sh.Name Like "###" Then
        i = CLng(Left(sh.Name, 1))
        If wb(i) Is Nothing Then Set wb(i) = Workbooks.Add(xlWBATWorksheet)
        sh.Move after:=wb(i).Worksheets(wb(i).Worksheets.Count)
    End If
Next
'--- Workbooks speichren
Application.DisplayAlerts = False
For i = 0 To UBound(wb)
    If Not wb(i) Is Nothing Then
        wb(i).Sheets(1).Delete
        wb(i).SaveAs Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & "-" & i,  _
FileFormat:=xlExcel12
        wb(i).Close
    End If
Next
Application.DisplayAlerts = True
End Sub
gruß Daniel

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Variable Tabellenblätter verschieben "