via Makro neue Mappe inklusive Speichern
01.07.2020 13:29:07
Tim
ich habe ein Makro welches mir Daten aus einer Mappe in einer neue Mappe übernimmt, das funktioniert perfekt. Die neue Herausforderung besteht darin, aus der Ursprungsmappe, mehrere einzelne Mappen zu erstellen und jede einzelne unter einen neuen Dateinamen zu speichern.
Als Ausgangspunkt dient die erste Spalte in der Ursprungsmappe. Diese hat verschiedene Nummern, die mehrfach vorkommen, sobald alle Informationen zu den mehrfach vorkommenden Nummern in die neue Mappe übernommen wurde, soll die Datei selbständig gespeichert werden, wer kann mir dabei helfen?
Sub Import()
Dim WbQ As Workbook, WbZ As Workbook, WsQ As Worksheet, wksQ As Worksheet
Dim WsZ As Worksheet
Dim i As Long, letzte As Long, ImportListe As Long
Dim a As Variant, Fehler As Boolean
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Bitte einzulesende Datei wählen..."
.AllowMultiSelect = False
If .Show -1 Then
MsgBox "Vorgang abgebrochen!", vbInformation
Exit Sub
Else: Pfad = .SelectedItems(1)
End If
End With
Set WbQ = Workbooks.Open(Pfad)
Set WsQ = WbQ.Worksheets(1)
Set WbZ = Workbooks.Add(template:=xlWBATWorksheet)
Set WsZ = WbZ.Worksheets(1)
Set wksQ = GetObject("O:\Test\Test.xlsx").Worksheets("0815")
letzte = WsQ.Cells(WsQ.Rows.Count, 2).End(xlUp).Row
ImportListe = WsZ.Cells(WsZ.Rows.Count, 1).End(xlUp).Row
For i = 2 To letzte
a = Application.Match(WsQ.Cells(i, 2), wksQ.Columns(1), 0)
If Not IsNumeric(a) Then
Fehler = True
WsQ.Cells(i, 1).Value = WsQ.Cells(i, 1).Value & " nicht gefunden"
WsQ.Cells(i, 1).Interior.ColorIndex = 3
Else
WsZ.Cells(ImportListe + 1, 1) = WsQ.Cells(i, 1)
WsZ.Cells(ImportListe + 1, 2) = wksQ.Cells(a, 2).Value 'Artikelnummer
WsZ.Cells(ImportListe + 1, 3) = "1" 'Menge
ImportListe = ImportListe + 1
End If
Next
With WsZ
.Cells(1, 1) = "Test1"
.Cells(1, 2) = "Test2"
.Cells(1, 3) = "Test3"
End With
If Fehler = True Then MsgBox "Fehlermeldung", 48, " Hinweis für " & Application.UserName
Set WbQ = Nothing: Set WbZ = Nothing: Set WsQ = Nothing
Set WsZ = Nothing: Set tQ = Nothing: Set wksQ = Nothing
End Sub