Hallo, stehe noch am Anfang meiner VBA Karriere und hoffe hier ein paar Inspitarionshilfen zu bekommen. Bisher habe ich mir nur im Internet aus geposteten Makros eine halbwegs funktionierende Operationsabfolge zusammenkopiert. Jetzt komme ich aber nicht mehr weiter.
Zu meinem Problem: Ich möchte alle Dateien in einem Unterordner \Inputs\ öffnen, ein bestimmtes Arbeitsblatt dessen Name immer gleich ist in den geöffneten Dateien suchen und kopieren z.B. "Commercial", und dann dieses Tabellenblatt in eine bestimmte Datei im Hauptordner rein kopieren.
Bisher habe ich die Dateinamen in dem Ordner Inputs immer manuell angepasst (Im Beispiel unten 1.xlsx) damit mein Makro lief, diesen Schritt möchte ich aber jetzt automatisieren. Bisher hatte ich folgendes Makro verwendet.
Public Sub CommandButton1_Click() ' Wertekopieren()
Application.ScreenUpdating = False
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim wb3 As Workbook
Dim wb4 As Workbook
Dim wb5 As Workbook
Dim wb6 As Workbook
Dim wb7 As Workbook
Dim wb8 As Workbook
Dim wb9 As Workbook
Dim wb10 As Workbook
Dim wb11 As Workbook
Dim wb12 As Workbook
Dim wb13 As Workbook
Dim wb14 As Workbook
Dim wb15 As Workbook
Dim wb16 As Workbook
Dim wb17 As Workbook
Dim wb18 As Workbook
Dim pfadinputs As String
Dim pfadoutputs As String
Dim wb1name As String
Dim wb2name As String
Dim wb3name As String
Dim wb4name As String
Dim wb5name As String
Dim wb6name As String
Dim wb7name As String
Dim wb8name As String
Dim wb9name As String
Dim wb10name As String
Dim wb11name As String
Dim wb12name As String
Dim wb13name As String
Dim wb14name As String
Dim wb15name As String
Dim wb16name As String
Dim wb17name As String
Dim wb18name As String
Dim wb1ws1 As Worksheet
Dim wb2ws1 As Worksheet
Dim wb3ws1 As Worksheet
Dim wb4ws1 As Worksheet
Dim wb5ws1 As Worksheet
Dim wb6ws1 As Worksheet
Dim wb7ws1 As Worksheet
Dim wb8ws1 As Worksheet
Dim wb9ws1 As Worksheet
Dim wb10ws1 As Worksheet
Dim wb11ws1 As Worksheet
Dim wb12ws1 As Worksheet
Dim wb13ws1 As Worksheet
Dim wb14ws1 As Worksheet
Dim wb15ws1 As Worksheet
Dim wb16ws1 As Worksheet
Dim wb17ws1 As Worksheet
Dim wb18ws1 As Worksheet
Dim bwbopen As Boolean
Application.ScreenUpdating = False 'Das "Flackern" ausstellen
Application.DisplayAlerts = False 'Keine Fehlermeldungen anzeigen
' 1 Commercial
On Error GoTo Weiter1
pfadinputs = ThisWorkbook.Path & "\INPUTS\" ' Datenarbeitsmappepfad
wb1name = "1.xlsx" ' Datenarbeitsmappename
pfadoutputs = ThisWorkbook.Path & "\" ' Zielarbeitsmappepfad
wb2name = "1. Commercial.xlsx" ' Zielarbeitsmappename
bwbopen = WorkbookIsOpen(wb1name)
If bwbopen = False Then
Workbooks.Open (pfadinputs & wb1name), ReadOnly:=True, UpdateLinks:=0
Else
End If
bwbopen = WorkbookIsOpen(wb2name)
If bwbopen = False Then
Workbooks.Open (pfadoutputs & wb2name), ReadOnly:=False, UpdateLinks:=0
Else
End If
Set wb1 = Workbooks(wb1name)
Set wb2 = Workbooks(wb2name)
Set wb1ws1 = wb1.Worksheets("Commercial") ' Datenarbeitsmappentabelle
Set wb2ws1 = wb2.Worksheets("Commercial") ' Zielarbeitsmappentabelle
wb1ws1.Cells.Copy
wb2ws1.Cells.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
If bwbopen = False Then
wb1.Activate
ActiveWorkbook.Saved = True
ActiveWorkbook.Close False
Else
End If
If bwbopen = False Then
wb2.Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
Else
End If
Range("A1").Select
Weiter1:
On Error Resume Next
bwbopen = WorkbookIsOpen(wb1name)
If bwbopen = True Then
wb1.Activate
ActiveWorkbook.Saved = True
ActiveWorkbook.Close
Else
End If