Excel Tabelle in einzelne Exceldateien

Hallo Zusammen,
ich hatte diesen Beitrag am 08.01.2021 eingestellt und netterweise von Nepumuk auch eine Antwort drauf erhalten. Die war generell schon sehr gut, allerdings hat sich leider an Umständen was geändert.
@Nepumuk: Ich muss die Daten aus der Quelldatei in eine bestimmte Zieldatei eintragen, sprich es gibt dazu ein Template...das würde ich Dir mal hier anhängen...die Daten aus der Quelldatei wären dann auch fix Zellen in diesem Template zugeordnet, so soll dann z.B. aus der Quelldatei der Wert aus A2 in das Template Zelle C5. Im Template habe ich das Mapping zu der Quelldatei hinterlegt...
...nun müsste jede Zeile aus der Quelldatei in das Template eingetragen werden (pro Zeile eine neue Datei).
Wenn Du mir dabei noch helfen könntest wäre ich Dir sehr dankbar.
Du brauchst natürlich nicht jedes Mapping zu programmieren, wenn ich Beispiele habe wie es funktioniert kann ich die Masse auch hinterlegen - ist ja sicherlich immer das gleiche Coding...
Vielen Dank schon mal vorab!!
Viele Grüße Addi

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Addi,
hier das Makro von Nepumuk angepasst an die neuen Vorgaben.
LG
Franz

Public Sub DatenAufteilen()
Dim lngInputRow As Long, lngOutputRow As Long, lngColumn As Long
Dim objInputSheet As Worksheet, objOutputSheet As Worksheet
Dim objWorkbook As Workbook
Application.ScreenUpdating = False
Set objOutputSheet = ActiveSheet
'Vorlage schreibgeschützt öffnen - Verzeichnis und/oder Name der Vorlage anpassen !!!
Set objWorkbook = Application.Workbooks.Open(ThisWorkbook.Path & "\Vorlage_Addi.xlsx", _
ReadOnly:=True)
Set objInputSheet = objWorkbook.Worksheets(1)
With objOutputSheet
For lngOutputRow = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'Inhalte in Eingabe-Zellen der Vorlage löschen
'          objInputSheet.Range("C4:C77").ClearContents
For lngInputRow = 5 To 73
Select Case lngInputRow
Case 5, 8, 15, 21, 27, 30, 33, 36, 40, 43, 46, 49, 52, 55, 58, 64, 67, 73
objInputSheet.Cells(lngInputRow, 3).ClearContents
End Select
Next
For lngColumn = 1 To 18 'A bis R
lngInputRow = 0
'Zeilennummer im Zielblatt der Spalte zuordnen
Select Case lngColumn
Case 1: lngInputRow = 5 'Name der Gesellschaft A2
Case 2: lngInputRow = 8 'Neuanlage, Änderung, Löschung B2
Case 3: lngInputRow = 15 'Angabe zur Kundenart  C2
Case 4: lngInputRow = 21 'Vorname D2
Case 5: lngInputRow = 27 'Zusatzname E2
Case 6: lngInputRow = 30 'Rechtsform F2
Case 7: lngInputRow = 33 'Suchbegriff G2
Case 8: lngInputRow = 36 'UST-ID Nr. Kunden H2
Case 9: lngInputRow = 40 'steuerliche Ansässigkeit des Kunden I2
Case 10: lngInputRow = 43 'Straße/Hausnummer J2
Case 11: lngInputRow = 46 'Postleitzahl/Ort  K2
Case 12: lngInputRow = 49 'Land L2
Case 13: lngInputRow = 52 'Sprache M2
Case 14: lngInputRow = 55 'E-Mail des Kunden N2
Case 15: lngInputRow = 58 'E-Mail des Ansprechpartners O2
Case 16: lngInputRow = 64 'Gesellschaft / Buchungskreis  P2
Case 17: lngInputRow = 67 'Rechnungsversand Q2
Case 18: lngInputRow = 73 'Name des internen Antragstellers  R2
End Select
If lngInputRow > 0 Then
objInputSheet.Cells(lngInputRow, 3).Value = _
.Cells(lngOutputRow, lngColumn).Value
Select Case lngInputRow
Case 55, 58 'E-Mail des Kunden / E-Mail des Ansprechpartners
objInputSheet.Hyperlinks.Add objInputSheet.Cells(lngInputRow, 3), _
"mailto:" & .Cells(lngOutputRow, lngColumn).Text
End Select
End If
Next
Call objWorkbook.SaveCopyAs(Filename:=ThisWorkbook.Path & "\" & _
objOutputSheet.Cells(lngOutputRow, 1).Text & ".xlsx")
Next
End With
'Vorlage wieder schliessen
objWorkbook.Close savechanges:=False
Set objOutputSheet = Nothing
Set objInputSheet = Nothing
Set objWorkbook = Nothing
Application.ScreenUpdating = True
End Sub

Beliebteste Forumthreads (12 Monate)

Excel Tabelle in einzelne Exceldateien

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread