Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1612to1616
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Sheets hinaus- und hineinkopieren

Sheets hinaus- und hineinkopieren
06.03.2018 11:40:23
Chris
Hallo VBAler,
ich benötige ein Makro, das aus dem Ordner "Test" (auf dem Desktop) alle
XLSX.Dateien , die ein "-" enthalten kurz öffnet, dort alle befindlichen Sheets, die im Sheetnamen "MB" enthalten hinauskopiert und die jeweiligen Sheets mit gleichem Sheetname in eine leere Excel-Datei hintereinander hineinkopiert.
Meine VBA-Kenntnisse reichen leider nicht aus. Hat jmd. so ein Makro vielleicht schon gebastelt?
Danke und viele Grüße
Chris

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Sheets hinaus- und hineinkopieren
06.03.2018 12:51:29
UweD
Hallo
in ein Modul
Option Explicit 
 
Sub alle_Dateien_Verzeichnis() ' 
    On Error GoTo Fehler 
    Dim Pfad As String, Ext As String, Datei As String 
    Dim WB, TB 
    Dim WSHShell As Object 
    Dim DesktopPath As String 
    Set WSHShell = CreateObject("wscript.Shell") 
     
    DesktopPath = WSHShell.SpecialFolders.Item("Desktop") 
    Pfad = DesktopPath & "\Test\" 
 
    Ext = "*-*.xlsx" 
     
    Datei = Dir(Pfad & Ext) 
     
    Application.ScreenUpdating = False 
     
    Do While Len(Datei) > 0 
        Workbooks.Open Filename:=Pfad & Datei 
        Set WB = ActiveWorkbook 
        For Each TB In WB.Sheets 
            If InStr(TB.Name, "MB") > 0 Then 
                TB.Copy 
                With ActiveWorkbook 
                    .SaveAs Filename:=Pfad & TB.Name & ".xlsx", FileFormat:= _
                        xlOpenXMLWorkbook 
                    .Close 
                End With 
            End If 
        Next 
         
        Workbooks(Datei).Close False 
         
        Datei = Dir() ' nächste Datei 
    Loop 
     
    Err.Clear 
Fehler: 
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear 
 
End Sub 
 

LG UweD
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige