Daten in andere Mappe kopieren

Sub Daten_nach_Ziel()
Dim wbQuelle As Workbook, wbZiel As Workbook
Dim wksQuelle As Worksheet, wksZiel As Worksheet, wksSteuer As Worksheet
Dim Zeile As Long, Spalte As Long, Zeile_L As Long, Art_Zaehler As Long
Dim Zeile_Z As Long
Dim sPfad As String, sDatei As String
Dim Anz_Artikel As Long
Dim arrFiles() As String, iI As Long, PfadNeu As String, NameNeu As String
'Zeilen-/Spaltenvorgaben im Quell-Tabellenblatt
Const ZeileArtikel As Long = 12       'Zeile mit Artikelnummern
Const ZeileNettoEK As Long = 28       'Zeile mit Netto EK-Preisen
Const ZeileFiliale_1 As Long = 41     'Zeile mit Daten der 1. Filiale
Const Spalte_EP = 4                   'Spalte D - EP-Mitglied
Const Spalte_Art_1 = 7                'Spalte G - Spalte 1. Artikel
Const Spalte_Menge_1 As Long = 11     'Spalte K - Spalte Menge 1. Artikel
Const AnzSpalten_Artikel As Long = 11 'Anzahl Spalten pro Artikel
'Zeilen-/Spaltenvorgaben im Ziel-Tabellenblatt
Const Spalte_AG = 5                   'Spalte E - Auftraggeber
Const Spalte_Art_Z = 14               'Spalte N - Artikel
Const Spalte_Menge_Z As Long = 15     'Spalte O - Spalte Auftragsmenge
Const Spalte_EK_Z As Long = 16        'Spalte P - Spalte Nettopreis
On Error GoTo Fehler
Set wksSteuer = ThisWorkbook.Worksheets("Steuerung")
'Verzeichnis mit den Quelldateien
sPfad = wksSteuer.Range("Verzeichnis.Quelle").Value
'Verzeichnis in das die Quelldateien verschoben werden sollen
PfadNeu = wksSteuer.Range("Verzeichnis.Neu").Value
sDatei = Dir(sPfad & Application.PathSeparator & "*.xls*")
If sDatei = "" Then
MsgBox "Im gewählten Verzeichnis wurden keine Excel-Dateien gefunden!"
GoTo Beenden
End If
'Dateinamen einlesen
iI = 0
Do Until sDatei = ""
iI = iI + 1
ReDim Preserve arrFiles(1 To iI)
arrFiles(iI) = sPfad & Application.PathSeparator & sDatei
sDatei = Dir
Loop
Application.ScreenUpdating = False
For iI = LBound(arrFiles) To UBound(arrFiles)
'Bearbeitungsfortschritt in Statuszeile anzeigen
Application.StatusBar = "Bearbeite Datei " & iI & " von " & UBound(arrFiles) _
& " - " & arrFiles(iI)
'Muster-Arbeitsmappe für Zieldaten schreibgeschützt öffnen
Set wbZiel = Application.Workbooks.Open(Filename:=wksSteuer.Range("Datei.Muster").Value, _
ReadOnly:=True)
Set wksZiel = wbZiel.Worksheets(wksSteuer.Range("Blatt.Ziel").Value)
'Letzte belegte Datenzeile in Zieltabelle
With wksZiel
Zeile_Z = .Cells(.Rows.Count, Spalte_AG).End(xlUp).Row
End With
'Arbeitsmappe mit Quelldaten schreibgeschützt öffnen
Set wbQuelle = Application.Workbooks.Open(Filename:=arrFiles(iI), _
ReadOnly:=True, UpdateLinks:=False)
Set wksQuelle = wbQuelle.Worksheets(wksSteuer.Range("Blatt.Quelle").Value)
With wksQuelle
'Zeile mit letzter Filiale
Zeile_L = .Cells(ZeileFiliale_1, Spalte_EP).End(xlDown).Row
'Anzahl Artikel ermitteln
Anz_Artikel = (.Cells(ZeileArtikel, .Columns.Count).End(xlToLeft).Column - _
Spalte_Art_1) / AnzSpalten_Artikel + 1
'Artikel abarbeiten
For Art_Zaehler = 1 To Anz_Artikel
'Spalten-Offset zur Spalte des 1. Artikels
Spalte = (Art_Zaehler - 1) * AnzSpalten_Artikel
'Daten der Filialen übertragen
For Zeile = ZeileFiliale_1 To Zeile_L
'Prüfen, ob Bestellmenge > 0
If .Cells(Zeile, Spalte + Spalte_Menge_1) > 0 Then
Zeile_Z = Zeile_Z + 1
wksZiel.Cells(Zeile_Z, Spalte_AG) = .Cells(Zeile, Spalte_EP)
wksZiel.Cells(Zeile_Z, Spalte_Art_Z) = .Cells(ZeileArtikel, Spalte + Spalte_Art_1)
wksZiel.Cells(Zeile_Z, Spalte_Menge_Z) = .Cells(Zeile, Spalte + Spalte_Menge_1)
wksZiel.Cells(Zeile_Z, Spalte_EK_Z) = .Cells(ZeileNettoEK, Spalte + Spalte_Art_1)
End If
Next
Next
End With
'Zieldatei unter neuem Namen speichern
NameNeu = Left(wbQuelle.FullName, InStrRev(wbQuelle.FullName, ".") - 1) _
& Format(Now, " YYYYMMDD_hhmmss")
wbZiel.SaveAs Filename:=NameNeu
wbZiel.Close
'Neuer Name der Quelldatei
NameNeu = PfadNeu & Application.PathSeparator & wbQuelle.Name
'Quelldatei schliessen
wbQuelle.Close savechanges:=False
'Quelldatei verschieben/umbenennen
Name arrFiles(iI) As NameNeu
Set wbQuelle = Nothing
Set wbZiel = Nothing
Next
MsgBox "Fertig!"
Beenden:
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, vbInformation + vbOKOnly, _
"Makro - Daten_nach_Ziel"
End Select
End With
'Quell- und/oder Zieldatei nach Fehler ggf. schliessen.
If Not wbZiel Is Nothing Then wbZiel.Close savechanges:=False
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
'Objektvariablen und variable Datenarrays zurücksetzen
Erase arrFiles
Set wbQuelle = Nothing: Set wbZiel = Nothing
Set wksQuelle = Nothing: Set wksZiel = Nothing
'Einstellungen der Anwendung zurücksetzen
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

Sub Quellverzeichnis()
'Verzeichnis mit den Quelldateien ausswählen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit Datendateien auswählen"
.ButtonName = "Auswählen"
If .Show = -1 Then
Worksheets("Steuerung").Range("Verzeichnis.Quelle") = .SelectedItems(1)
End If
End With
End Sub

Sub QuellverzeichnisNeu()
'Neus Verzeichnis für die Quelldateien ausswählen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte neues Verzeichnis für Datendateien auswählen"
.ButtonName = "Auswählen"
If .Show = -1 Then
Worksheets("Steuerung").Range("Verzeichnis.Neu") = .SelectedItems(1)
End If
End With
End Sub

Sub MusterZielDatei()
'Musterdatei für Zieldatei ausswählen
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte Musterdatei für Zieldaten auswählen"
.ButtonName = "Auswählen"
If .Show = -1 Then
Worksheets("Steuerung").Range("Datei.Muster") = .SelectedItems(1)
End If
End With
End Sub