AW: Du solltest Deinen Vorgängertread verlinken ...
17.01.2021 00:26:01
fcs
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