Excel makro / Von sheet zu sheet kopieren und duplizieren

[scolaAP]

Hallo erstmal

Ich habe hier ein kleines Problem bei Excel.
Ich habe zwei Sheets in Excel...... "FORMULAR" und "KUNDENLISTE".
Aus der Kundenliste soll aus einer Spalte die Kundennummer abgegriffen werden und in eine bestimmte Zelle im Formular gesetzt werden. Dannach soll eine Kopie von dem Reiter gemacht werden und dann das gleiche mit der nächsten Kundennummer gemacht werden. Ich habe soweit ich mich auskenne was hinbekommen:

Sub TEST()
'
' TEST Makro
'

'
Sheets("KUNDENLISTE").Select
Range("E6").Select
Selection.Copy
Sheets("FORMULAR").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("FORMULAR").Select
Application.CutCopyMode = False
Sheets("FORMULAR").Copy Before:=Sheets(1)
Sheets("KUNDENLISTE").Select
Range("E7").Select
Selection.Copy
Sheets("FORMULAR").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("FORMULAR").Select
Application.CutCopyMode = False
Sheets("FORMULAR").Copy Before:=Sheets(2)
Sheets("KUNDENLISTE").Select
Range("E8").Select
Selection.Copy
Sheets("FORMULAR").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("FORMULAR").Select
Application.CutCopyMode = False
Sheets("FORMULAR").Copy Before:=Sheets(3)
Sheets("KUNDENLISTE").Select
Range("E9").Select
Selection.Copy
Sheets("FORMULAR").Select
Range("E4").Select
ActiveSheet.Paste
Sheets("FORMULAR").Select
Application.CutCopyMode = False
Sheets("FORMULAR").Copy Before:=Sheets(4)
End Sub

Das Problem hierbei ist das ich für 3000 Kundennummern keinen super langen Code schreiben will.
Kennt jemand eine Lösung wie man das so hinbekommt das er eine task wiederholt bis keine Zahlen mehr zu sehen sind oder der Inhalt der Zelle leer ist? Natürlich wäre die idealste Lösung das die Kundennummer rüber kopiert wird und ein PDF von dem Formular geschrieben wird und das dann so weiter. Ich musste das bisher in Excel mit dem Formular so machen weil noch andere Daten in der Kundenliste abgegriffen werden und es deshalb auch von dem einem Reiter in den anderen kopiert werden muss.

Ich hoffe jemand kann mir dazu helfen
Bis dahin.... have a nice day!
Scola

 

[starvin]

Ohne Gewähr, bin kein Experte auf dem Gebiet.
Bitte zunächst mit dem Debugger Schritt für Schritt durchgehen ob es funktioniert.
Dazu das Makro öffnen und mit F8 Zeile für Zeile den Code durchlaufen lassen.

Das Makro bitte in die FORMULAR Datei einfügen.
Beide Dateien müssen geöffnet sein.

Habe alles was du bearbeiten musst kommentiert, falls Fragen sind nur zu.

Der Dateiname der PDF setzt sich aus "FilenamePDF" einem Unterstrich und der Kundennummer zusammen.


Edit: Sorry, habe gerade gesehen es handelt sich um zwei Sheets in einer Datei und nicht um zwei Dateien.
Also in dem Fall Windows().Activate durch Sheets().Select ersetzten und bei den Filenames nur den Blattnamen eingeben.

Sub Kundennummer_Import_PDF()
'
' Kundennummer_Import_PDF Makro
'

' Dateiname Quelle
    FilenameSource = "KUNDENLISTE.xlsx"
' Dateiname Ziel (Beachte hier .xlsm da Makro)
    FilenameTarget = "FORMULAR.xlsm"
' Export Pfad für die PDF (z.B. C:\Benutzer\User\Eigene Dokumente)
    Path = "C:\Benutzer\User\Eigene Dokumente"
' Dateiname der PDF
    FilenamePDF = "FORMULAR"
' Anzahl der Kundennummern
    Anzahl = 4
' Spalte für 1. Kundennummer (Auswahl)
    SourceSpalte = "E"
' Zeile für 1. Kundennummer (Auswahl)
    SourceZeile = 6
' Spalte für Kundennummer (Einfügen)
    TargetSpalte = "E"
' Zeile für Kundennummer (Einfügen)
    TargetZeile = 4

    Dim intRow As Integer
    For intRow = 1 To Anzahl
    Windows(FilenameSource).Activate
    Range(SourceSpalte & SourceZeile).Select
    Kundennummer = Range(SourceSpalte & SourceZeile).Value
    Selection.Copy
    Windows(FilenameTarget).Activate
    Range(TargetSpalte & TargetZeile).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir Path
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Path & "\" & FilenamePDF & "_" & Kundennummer & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
    SourceZeile = SourceZeile + 1
    Next intRow

End Sub

 

[CHaos.Gentle]

Moin,

alles möglich, aber nicht ganz trivial.
Deine Idee, dass in Reiter zu verfrachten ist allerdings keine gute. Die maximale Anzahl ist zwar nur durch den Arbeitsspeicher beschränkt, aber wenn das Ding nach 2000 abstirbt, ist das irgendwie suboptimal.

Ob dir jetzt hilft, was ich dir zeige, weiß ich nicht, aber ich habe gerade nicht viel Zeit.

Oder so... Jetzt war ich zu spät
Egal

Sub knd2pdf()
Application.ScreenUpdating = False
Const SaveFolder = "c:\temp" ' <-------------- Verzeichnis für PDF Ausgabe
Const DocNamePrefix = "Formular_" ' <--------- Dateiname für Dokument (gefolgt von Kundennummer)
Const kndnr_col = 5 ' <----------------------- Kundennummerspalte
Const start_row = 6 ' <----------------------- Erste Zeile mit Kundennummer
Dim i As Integer
Dim sWS As Worksheet
Dim tWS As Worksheet

Set sWS = Worksheets("KUNDENLISTE")
Set tWS = Worksheets("FORMULAR")

i = start_row

On Error GoTo preErr
tWS.Select
While Not sWS.Cells(i, kndnr_col).Value = ""
  tWS.Cells(4, 5).Value = sWS.Cells(i, 5).Value
  SaveToExtra SaveFolder, DocNamePrefix & sWS.Cells(i, 5).Value
  i = i + 1
Wend

On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub

preErr:
MsgBox "Fehler beim Vorbereiten des Drucks"
Application.ScreenUpdating = True
End Sub

Sub SaveToExtra(SaveFolder As String, DokName As String)
Application.PrintCommunication = False
On Error Resume Next
With ActiveSheet.PageSetup
  .PrintArea = "$A1:$K30" ' <----------------------------- Zu druckende Zellen eintragen
  .LeftHeader = ""
  .CenterHeader = "&F"
  .RightHeader = ""
  .LeftFooter = ""
  .CenterFooter = ""
  .RightFooter = "Seite: &P" ' <------------------------- Fußzeile????
  .LeftMargin = Application.InchesToPoints(0.393700787401575)
  .RightMargin = Application.InchesToPoints(0)
  .TopMargin = Application.InchesToPoints(0.393700787401575)
  .BottomMargin = Application.InchesToPoints(0.236220472440945)
  .HeaderMargin = Application.InchesToPoints(0.15748031496063)
  .FooterMargin = Application.InchesToPoints(0)
  .PrintHeadings = False
  .PrintGridlines = False
  .PrintComments = xlPrintNoComments
  .PrintQuality = 600
  .CenterHorizontally = False
  .CenterVertically = False
  .Orientation = xlLandscape
  .Draft = False
  .PaperSize = xlPaperA4
  .FirstPageNumber = xlAutomatic
  .Order = xlDownThenOver
  .BlackAndWhite = False
  .Zoom = False
  .FitToPagesWide = 1
  .FitToPagesTall = False
  .PrintErrors = xlPrintErrorsDisplayed
  .OddAndEvenPagesHeaderFooter = False
  .DifferentFirstPageHeaderFooter = False
  .ScaleWithDocHeaderFooter = True
  .AlignMarginsHeaderFooter = False
  .EvenPage.LeftHeader.Text = ""
  .EvenPage.CenterHeader.Text = ""
  .EvenPage.RightHeader.Text = ""
  .EvenPage.LeftFooter.Text = ""
  .EvenPage.CenterFooter.Text = ""
  .EvenPage.RightFooter.Text = ""
  .FirstPage.LeftHeader.Text = ""
  .FirstPage.CenterHeader.Text = ""
  .FirstPage.RightHeader.Text = ""
  .FirstPage.LeftFooter.Text = ""
  .FirstPage.CenterFooter.Text = ""
  .FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
On Error GoTo saveErr
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SaveFolder & "\" & DokName & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
On Error GoTo 0
Exit Sub
saveErr:
MsgBox "Beim Erzeugen des PDF-Dokumentes ist ein Fehler aufgetreten.", , "Fehler beim PDF erstellen"
End Sub

 

[starvin]

Falls du auf meine Variante zurück greifst würde ich dir empfehlen das Script zunächst mal nur in 100-200 Packs zu aktivieren. Also z.B. von 6 - 106, 107 - 207, etc. und dich langsam ranzutasten. Keine Ahnung wie dein PC auf die 3000 Zeilen Schleife mit PDF Export reagieren wird.

 

[CHaos.Gentle]

Ja und ne Sicherheitskopie von den Orginalen ist auch nie verkehrt ^^

 

[scolaAP]

Hi Leute, erstmal vielen Dank für die schnelle Antworten.

Starvin, du bist ein Gott!
Dein Code funktioniert super nachdem ich das mit dem Sheets().Select geändert hatte.
Ein kleine Frage hätte ich da aber noch.
Wenn ich die PDF´s in Rheinfolge behalten möchte, wie kann ich das machen?
Kann man eine fortlaufende Nummerierung vorne an die PDF generieren?

Schönen Gruß,
Scola

 

[starvin]

Freut mich. Lerne gerne immer mal wieder etwas neues, von daher war das eine gelungene Nebenaufgabe.

Versuch es mal hiermit:

Sub Kundennummer_Import_PDF()
'
' Kundennummer_Import_PDF Makro
'

' Blattname Quelle
    sourceSheet = "KUNDENLISTE"
' Blattname Ziel
    targetSheet = "FORMULAR"
' Export Pfad für die PDF (z.B. C:\Benutzer\User\Eigene Dokumente)
    Path = "C:\Benutzer\User\Eigene Dokumente"
' Dateiname der PDF
    filenamePDF = "FORMULAR"
' Anzahl der Kundennummern
    Anzahl = 3
' Spalte für 1. Kundennummer (Auswahl)
    sourceSpalte = "E"
' Zeile für 1. Kundennummer (Auswahl)
    sourceZeile = 6
' Spalte für Kundennummer (Einfügen)
    targetSpalte = "E"
' Zeile für Kundennummer (Einfügen)
    targetZeile = 4
   
    letzteZeile = sourceZeile + Anzahl
    leadingZeros = ""
   
    Do
    leadingZeros = leadingZeros & "0"
    letzteZeile = letzteZeile / 10
    Loop Until letzteZeile < 1
   
    Dim intRow As Integer
    For intRow = 1 To Anzahl
    prefix = Strings.Format(sourceZeile, leadingZeros)
    Sheets(sourceSheet).Select
    Range(sourceSpalte & sourceZeile).Select
    Kundennummer = Range(sourceSpalte & sourceZeile).Value
    Selection.Copy
    Sheets(targetSheet).Select
    Range(targetSpalte & targetZeile).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir Path
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Path & "\" & prefix & "_" & filenamePDF & "_" & Kundennummer & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
        False
    sourceZeile = sourceZeile + 1
    Next intRow

End Sub

Der PDF Bezeichnung wird jetzt noch die jeweilige Zeilennummer (mit führenden Nullen) vorangestellt.

 

[scolaAP]

Hi Starvin!
Dein Code funktioniert wunderbar!
Vielen lieben Dank für die schnelle Hilfe.

Schönen Gruß,
Scola