Makro unterbrechen oder anhalten zwecks "Zwischenspeichern"

[Pr3d4tor]

Guten Morgen zusammen,

ich benötigen mal wieder fachlichen Hilfe oder auch den Schubser in die richtige Richtung

Aber erstmal ne Info vorab:
Grundsätzlich wird alles über Userform "gesteuert" welche beim öffnen der Mappe direkt geladen wird. Darin befindet sich unteranderem ein DropDown Menü welches durch das Auslesen eines festgelegten Ordners stattfinden, nach der Auswahl wird diese durch ein Button bestätigt.

Dies führt dazu das eine CSV in das aktive Workbook in Tabelle1 importiert wird. Anschließend kann/soll man über verschiedene "Auswahlmöglichkeiten" inkl. eines "Bestätigungsbutton" die Spalten A bis D und eine Anzahl von Zeilen (dafür die Auswahlmöglichkeit) in eine neue Arbeitsmappe kopieren.
Zum Schluß muss man noch an den vorgefertigten Dateiname eine Zahl hinzufügen und durch einen Speicher Button die neue Mappe speichern, schließen und zum "Ursprung" zurück kehren.

DAS ALLES KLAPPT auch soweit *zum Glück* ;-) .... allerdings scheitere ich nun daran die Aufteilung in einzelne Speichern "abfragen" aufzuteilen.
Ich erspare mir aber fürs erste die Datei so ab zu ändern um dann eine Beispieldatei hoch zu laden denn im Moment scheitere ich schon daran dass ich nicht einmal
weiß wonach ich genau Suche soll, mit welchen Befehlen sowas umsetzbar ist oder ob sowas überhaupt machbar ist.

Die Auswahl wird mit folgendem Code umgesetzt:

Private Sub CommandButton2_Click()
    Application.DisplayAlerts = False
          Dim NewBook As Workbook
            Set NewBook = Workbooks.Add
            NewBook.SaveAs Environ("Userprofile") & "\Documents\vFlp-Temp\" & "NewBook" & ".xls", True
        Application.DisplayAlerts = True

If OptionButton2.Value = False And OptionButton3.Value = False And OptionButton4.Value = False And OptionButton5.Value = False And OptionButton6.Value = False And OptionButton7.Value = False Then
TextBox1.Value = "Keine Paletten Anzahl ausgewählt"
End If

If OptionButton2.Value = True Then
    Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D15").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")

Workbooks("vFlp").Activate
End If

Das funktioniert auch ohne Probleme.
Was ich allerdings als Final brauche ist folgendes:
Egal welche Auswahl getroffen wird, es sollen als erstes immer "A1 : D4"in die neue Mappe kopiert werden. Anschließend der durch die Auswahl gewählte Bereich und abschließen die restlichen Zeilen danach bis zur letzten gefühlten Zelle.

Beispielcode dafür:

Private Sub CommandButton2_Click()
    Application.DisplayAlerts = False
          Dim NewBook As Workbook
            Set NewBook = Workbooks.Add
            NewBook.SaveAs Environ("Userprofile") & "\Documents\vFlp-Temp\" & "NewBook" & ".xls", True
        Application.DisplayAlerts = True

If OptionButton2.Value = False And OptionButton3.Value = False And OptionButton4.Value = False And OptionButton5.Value = False And OptionButton6.Value = False And OptionButton7.Value = False Then
TextBox1.Value = "Keine Paletten Anzahl ausgewählt"
End If

If OptionButton2.Value = True Then       
Dim loAnzahl As Long
    loAnzahl = Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D4").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A5:D20").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        'hier müsste jetzt das erstmal unterbrochen werden und das Eintrag der Flp Nr.01 inkl dem Speichern stattfinden'
        
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A20:D44").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        'hier müsste wieder unterbrochen werden und der Eintrag der Flp Nr.02 inkl dem Speichern stattfinden'
        
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A44:D" & loAnzahl).Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A16")
        'hier wird jetzt der Rest kopiert, benötigt eigentliche auch keine Nummer oder so... inkl dem Speichern stattfinden'

Workbooks("vFlp").Activate
End If

Gespeichert wird hiermit:

Private Sub CommandButton3_Click()
If txtFlp = "XX" Then 'Or txtFlp = 0 Then
MsgBox "Es wurde keine Nummer für die FLP angegeben"
    Exit Sub
        Else
            Call runExport
        MsgBox "CSV-Flp Datei wurde erfolgreich erstellt"
End If
End Sub

Wie bekomme ich es nun das der Ablauf unterbrochen wird, man die Flp Nr. eingibt, abspeichert und das ganze ab da weiterläuft?
Oder geht sowas händisch gar nicht? Bleibt dann aber wie ich das ganze Unterbreche und automatisch mit fortlaufender Nummer speichere.

Bin schon soweit gekommen aber jetzt kurz vorm Ende fehlte mir jede Idee und auch jede Wortwahl nach der ich Suche könnte um das ganze umzusetzen :-(

Hat einer von Euch vielleicht den richtigen Anstoß?#
Wie gesagt, der gesamte Code funktioniert ohne Probleme, ich scheitere jetzt nur an der geteilten Speicherung während des Ablaufs.



Danke vorab an alle..

Vg

 

[Yaslaw]

Ich bin beim Verstehen des 1ten Code-Teils bereits gescheitert.
OptionButton2, OptionButton3 etc. Wie heissen die? Was wählt da der User aus?
Du prüfst auf Option2-7 wertest aber nachher nur die Option2 aus.

Zu der Frage dort. Kopiere einfach, unabhängig von den Optionen den Range A14 und werte die Optionen erst danach aus.

Tipp: Im Form die Buttons und Felder so benennen, dass man im Code erkennt was sie sollen

Zur Nummerabfage. Einfach eine InputBox() nehmen und der ser wird aufgefordert etwas einzugeben.
Das Resultat prüfen ob es numerisch ist und ansonsten nachhacken.

    Dim varFlpNr
    Dim dblFlpNr As Long
    Dim prePrompt As String
    Do
        varFlpNr = InputBox(prePrompt & "Enter the Flp Nr (numeric)")
        If IsNumeric(varFlpNr) Then
            dblFlpNr = CLng(varFlpNr)
        Else
            prePrompt = "'" & varFlpNr & "' is not numeric. " & vbCrLf & vbCrLf
        End If
    Loop While dblFlpNr = 0
    MsgBox dblFlpNr

 

[Zvoni]

Ich seh noch ein anderes Problem.
1. Code - Zeile 5 (das NewBook.SaveAs)
Im 1. Parameter gibst du den Dateinamen an (korrekt inkl. Pfad), im zweiten ein "True" --> einen Boolean?
Workbook.SaveAs-Methode (Excel)
Der zweite Parameter ist das DateiFormat!!!
nur weil du ".xls" als Erweiterung hast, heisst es noch lange nicht, dass es im "alten" Excel-Format auch gespeichert wird

 

[Pr3d4tor]

Ich bin beim Verstehen des 1ten Code-Teils bereits gescheitert.
OptionButton2, OptionButton3 etc. Wie heissen die? Was wählt da der User aus?
Du prüfst auf Option2-7 wertest aber nachher nur die Option2 aus.

Ich finde die Bennenung der Buttons nicht wirklich relevant für die Lösung, habs aber mal geändert.
Und ich werte schon alle OptionButton aus, jedoch wiederholen die sich im Grunde daher habe ich nur ein Beispiel eingefügt.

Zur Nummerabfage. Einfach eine InputBox() nehmen und der ser wird aufgefordert etwas einzugeben.
Das Resultat prüfen ob es numerisch ist und ansonsten nachhacken.

    Dim varFlpNr
    Dim dblFlpNr As Long
    Dim prePrompt As String
    Do
        varFlpNr = InputBox(prePrompt & "Enter the Flp Nr (numeric)")
        If IsNumeric(varFlpNr) Then
            dblFlpNr = CLng(varFlpNr)
        Else
            prePrompt = "'" & varFlpNr & "' is not numeric. " & vbCrLf & vbCrLf
        End If
    Loop While dblFlpNr = 0
    MsgBox dblFlpNr

Bleibt für mich aber noch die Frage offen wie ich dies so einfüge dass das Erstellen der einzelnen Mappe klappt?

Ich seh noch ein anderes Problem.
1. Code - Zeile 5 (das NewBook.SaveAs)
Im 1. Parameter gibst du den Dateinamen an (korrekt inkl. Pfad), im zweiten ein "True" --> einen Boolean?
Workbook.SaveAs-Methode (Excel)
Der zweite Parameter ist das DateiFormat!!!
nur weil du ".xls" als Erweiterung hast, heisst es noch lange nicht, dass es im "alten" Excel-Format auch gespeichert wird

Das "True" muss mir beim kopieren aus einer anderen Mappe mitgerutscht sein, habs direkt mal rausgenommen und das Format hinzugefügt. Hoffe "51" ist da die beste Wahl gewesen?

Hier mal die angepasste Version:

Private Sub csvspeichern_Click()
If txtFlp = "XX" Then 'Or txtFlp = 0 Then
MsgBox "Es wurde keine Nummer für die FLP angegeben"
    Exit Sub
        Else
            Call runExport
        MsgBox "CSV-Flp Datei wurde erfolgreich erstellt"
End If
End Sub

Private Sub zellenCopyPaste_Click()
    Application.DisplayAlerts = False
          Dim NewBook As Workbook
            Set NewBook = Workbooks.Add
            NewBook.SaveAs Environ("Userprofile") & "\Documents\vFlp-Temp\" & "NewBook" & ".xlsx", FileFormat:=51
        Application.DisplayAlerts = True

If eineFlp.Value = False And zweiFlp.Value = False And dreiFlp.Value = False And fuenfFlp.Value = False And siebenFlp.Value = False And neunFlp.Value = False Then
TextBox1.Value = "Keine Paletten Anzahl ausgewählt"
End If

If eineFlp.Value = True Then
Dim loAnzahl As Long
    loAnzahl = Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D4").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A5:D15").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A5")
        'hier Speichern Flp Nr.1'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A16:D" & loAnzahl).Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A16")
        'hier speichern Flp Rest'
MsgBox "Vorgang war erfolgreich"
Workbooks("vFlp").Activate
End If

If zweiFlp.Value = True Then
Dim loAnzahl As Long
    loAnzahl = Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D4").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A5:D15").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A5")
        'hier speichern Flp Nr.1'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A16:D44").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A16")
        'hier speichern Flp Nr.2'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A45:D" & loAnzahl).Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A45")
        'hier speichern Flp Rest'
MsgBox "Vorgang war erfolgreich"
Workbooks("vFlp").Activate
End If
'usw'
End Sub

Hier habe mir jetzt schon Überlegt ob man nicht vielleicht auch einfach hingehen kann und anstatt der Abfrage nach der Nr. einfach eine zweite neue Mappe erstellen kann?

Also den Teil mit dem Erstellen der Mappe, wenn möglich, "zusammen" packt und dann beim
'hier speichern Flp Nr.1" das Newbook Speichert und ein Newbook1 erstellt usw.
Quasi sowas hier mal als Beispielt im Bezug auf den Code:

        Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D4").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A5:D15").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A5")
        'NewBook speichern und NewBook1 erstellen'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A16:D44").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A16")
        'NewBook1 speichern und NewBook2 erstellen'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A45:D" & loAnzahl).Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A45")
        'NewBook2 speichern und NewBook3 erstellen'

Oder Alternativ NewBook löschen, wird ja eh nur Temporär gespeichert ums bennen zu können.
Von mir aus auch gleichzeitg alle Newbooks erstellen wenn das mit ner Abfrage zwischem den Zeilen kopieren geht.



VG

 

[Yaslaw]

Erst mal - für sich mag es egal sein wie die Buttons heissen - für jeden der keine AHnung hat was du programmieren willst ist es eine grosse Hilfe.

Und achte auf deine Formatierung. Tabs am Anfang des Codes nach Zufallsprinzip macht den Code unlesbar.
Hier mal für alle anderen die helfen wollen, den Originalcode in lesbar, ergänzt um Funktionskommentar

'/**
' * Event beim Klicken des Buttons csvspeichern_Click
' * prüft auf die unbekannte Variabe txtFlp (ev diejenige die abgefragt werden soll?) und führt ggf ein unbekannter runExport() auf
' */
Private Sub csvspeichern_Click()
    If txtFlp = "XX" Then 'Or txtFlp = 0 Then
        MsgBox "Es wurde keine Nummer für die FLP angegeben"
        Exit Sub
    Else
        Call runExport
        MsgBox "CSV-Flp Datei wurde erfolgreich erstellt"
    End If
End Sub

'/**
' * Event beim Klicken des Buttons zellenCopyPaste_Click
' * <Hier Text einfügen was das Ding machen soll>
' */
Private Sub zellenCopyPaste_Click()
    Application.DisplayAlerts = False
    Dim NewBook As Workbook
    Set NewBook = Workbooks.Add
    NewBook.SaveAs Environ("Userprofile") & "\Documents\vFlp-Temp\" & "NewBook" & ".xlsx", FileFormat:=51
    Application.DisplayAlerts = True


    If eineFlp.Value = False _
            And zweiFlp.Value = False _
            And dreiFlp.Value = False _
            And fuenfFlp.Value = False _
            And siebenFlp.Value = False _
            And neunFlp.Value = False _
    Then
        TextBox1.Value = "Keine Paletten Anzahl ausgewählt"
    End If

    If eineFlp.Value = True Then
        Dim loAnzahl As Long
        loAnzahl = Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D4").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A5:D15").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A5")
        'hier Speichern Flp Nr.1'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A16:D" & loAnzahl).Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A16")
        'hier speichern Flp Rest'
        MsgBox "Vorgang war erfolgreich"
        Workbooks("vFlp").Activate
    End If

    If zweiFlp.Value = True Then
        Dim loAnzahl As Long
        loAnzahl = Worksheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A1:D4").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A1")
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A5:D15").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A5")
        'hier speichern Flp Nr.1'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A16:D44").Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A16")
        'hier speichern Flp Nr.2'
        Workbooks("vFlp").Worksheets("Tabelle1").Range("A45:D" & loAnzahl).Copy Destination:=Workbooks("NewBook").Worksheets("Tabelle1").Range("A45")
        'hier speichern Flp Rest'
        MsgBox "Vorgang war erfolgreich"
        Workbooks("vFlp").Activate
    End If
    'usw'
End Sub

Was war die Frage? Ich weiss auch nicht wo die die Nummerabfrage einbauen solltest, da ich nicht wiess was du damit machen willst. Was soll mit der abgefragten Nummer passieren?

Noch ein Tipp, COde der sich wiederholt sollte man in eine Funktion auslagern. Oder willst du den if-Block wirklich 7 mal programmieren?

 

[Pr3d4tor]

Erst mal - für sich mag es egal sein wie die Buttons heissen - für jeden der keine AHnung hat was du programmieren willst ist es eine grosse Hilfe.

Und achte auf deine Formatierung. Tabs am Anfang des Codes nach Zufallsprinzip macht den Code unlesbar.

Tachen,

vielen Dank erst einmal für deine Tipps, werde mir sie in Zukunft zu Herzen nehmen und auch den Ablauf über Kommentare verständlicher zu gestalten.

Was war die Frage? Ich weiss auch nicht wo die die Nummerabfrage einbauen solltest, da ich nicht wiess was du damit machen willst. Was soll mit der abgefragten Nummer passieren?

Noch ein Tipp, COde der sich wiederholt sollte man in eine Funktion auslagern. Oder willst du den if-Block wirklich 7 mal programmieren?

Was den Kompletten nutzen bzw. den Ablauf abgeht würde das den Rahmen aufgrund der Komplexität angeht sprengen und nur mehr Verwirrung stiften. Grundlegen wird die Ursprüngliche CSV Datei zur Datenerfassung in ein anderes Programm importiert und entsprechend den Vorgaben dort weiter „verarbeitet“. Wie sich mit der Zeit nun aber gezeigt hat ist bei manchen Dateien notwendig diese „Aufzuteilen“ und dafür werden immer die ersten vier Zeilen der Ursprungsdatei benötigt sowie die Daten ab Zeile fünf. Diese Daten dürfen aber nur einmal Vorkommen daher möchte ich diese aus der original Datei in eine separate CSV kopieren.

Aus diesem Grund habe oder versuche ich gerade ein Makro zu erstellen über das man die originale CSV Datei in Excel importiert, Excel die Zeilen 5 bis zur letzten gefüllten Zeile zählt, berechnet wie viele Flp (Flachpaletten) theoretisch erstellt werden können und dies in einer Textbox dann wiedergibt, was bisher auch fehlerfrei Funktioniert.

Bedeutet für mein weiteres Vorhaben und den Grund der Nummerierung folgendes.
Es wird die original Datei eingelesen und der User kann zwischen 0, 1, 2, 3, 5, 7, und 9 Flp auswählen (OptionButton 0 bis 7). Ob ich dafür die IF-Anweisung nun siebenmal wiederholen muss oder ob man dies auch in eine Funktion packen kann ist für mich zum einen erstmal Nebensache und auch außerhalb meiner bisherigen VBA Kenntnisse ;-)

Auf jeden Fall sollte es mit der Nummerierung wie folgt ablaufen.

- 1 Flp ausgewählt bedeutet:
Es werden die Zeilen A1-DX (momentan Denke ich an irgendwas zwischen Zeile D15 und D20) in eine neue Mappe kopiert. Dann muss diese neue Mappe gespeichert werden und soll die Nr.1 bekommen. Nachdem speichern müssen dann die Zeilen A1-D4 in eine neue Mappe kopiert werden sowie die Zeilen in dem Beispiel dann A16 oder A21 bis zur letzten gefüllten Zeile in diese Mappe kopiert werden. Diese Mappe würde dann entweder Nr.2 sein oder auch „Rest“.

- 2 Flp ausgewählt bedeutet:
Der gleiche Ablauf wie bei 1Flp nur das nach dem Speichern von Nr.1 die Zeilen A16 oder A21 bis Zeile D30 oder D35 in diese Mappe kopiert werden und mit Nr.2 gespeichert.
Danach werden dann noch A31 oder A36 bis zur letzten gefüllten Zeile kopiert und als Nr.3 oder „Rest“ gespeichert.

Also immer:
1Flp Zeilen A1 bis D15 als Nr.1, A16 bis zur letzten gefüllten Zeile als „Rest“
2Flp Zeilen A1 bis D15 als Nr.1, A16 bis D30 als Nr.2, A31 bis zur letzten gefüllten Zeile als „Rest“
usw.

Hoffe es jetzt etwas verständlicher geworden was ich im Grund benötige ;-)
Die Abfrage der Nummer dient nur dem Abspeichern und Bennenung der jeweiligen Datei und soll beim kopieren der Zeilen in die neue Mappe als "Unterbrechung" dienen.

Hab mal ein Foto von der UserForm angehangen. Wenn jetzt noch was unklar ist versuche ich mal am Wochenende eine Beispiel Datei zur Verfügung zu stellen.

 

[Yaslaw]

Merci, ich glaub ich versteh jetzt die Zusammenhänge. EIne Frage noch.

Wenn 7 Flp möglich sind, und der User wählt 5.
Was soll dann gemacht werden?
a) Die Fld Grösse verändert, so dass alle Daten auf 5 Flp verteilt werden
b) die Flp 6 und 7 einfach weggelassen wird
c) was anderes

 

[Pr3d4tor]

Im Grunde soll alles was an "Rest" noch vorhanden ist, abschließend in eine letzte Datei kopiert werden.

In deinem Beispiel: wenn 7 möglich sind und er nur 5 auswählt, wird der Rest(6 und7) bis zur letzten gefüllten Zeile kopiert und entweder als "FLP Rest" oder eben als "FLP 6" gespeichert.

Und was die Flp "größe" an sich angeht bin ich mir noch nicht so sicher.
Ich denke aber das es Pro FLP ... 15 bis 20 Zeilen werden sollen. Je nachdem wie die Programmierung bzw. das Makro am Ende aussieht/arbeitet. Vielleicht variiere ich das Ganze auch noch, wenn möglich.

 

[Yaslaw]

Ich habe Probleme, dein Code dierkt zu verbessern. Das Thema selber ist aber Interessant. Ich habe mir darum mal die Freiheit genommen, selber einen Code zu schreiben um dieses Problem anzugehen.

Mein Ansatz:

1. Letzter Lauf löschen
2. Berechnen der Anzahl Flp
3. Mit einem Loop durchgehen und diese erstellen

Weitere Erklärungen sind direkt im Code. In der Sub zellenCopyPaste_Click() muss natürlich noch die Form-Eingabe übernommen werden.

Deine Radiobuttons sind überflüssig.

Option Explicit

Const C_HEAD_ROWS& = 4                  'Anzahl Kopfzeilen die in jedes Flp kopiert werden
Const C_DATA_FIRST_COL& = 1             'Spalte A
Const C_DATA_LAST_COL& = 4              'Spalte D
Const C_DATA_SHEET_NAME$ = "vFlp"       'Name der Tabelle mit den Quelldaten
Const C_FLP_SIZE_DEFAULT& = 15          'Standard der Anzahl Datenzeilen pro Flp

'/**
' * Event beim Klicken auf den Button zellenCopyPaste
' * Liest die Eingaben aus dem Formular aus und startet die Aufteilung in die versch. Flp
' */
Private Sub zellenCopyPaste_Click()
    createFlps <TODO: Flipe-Nr aus dem Fomular>
End Sub

'/**
' * Teilt die Quelle in die einzelnen Flps auf
' * @param  Long    Anzahl Flp. Sollte dieser kleiner als 1 sein oder grösser als der berechnete Wert, wird er ignoriert. Standard = 0
' * @param  Long    Anzahl Zeilen pro Fld. Standard = C_FLP_SIZE_DEFAULT
' */
Public Sub createFlps(Optional ByVal iSelectedFlipCount& = -1, Optional ByVal iFlpSize& = C_FLP_SIZE_DEFAULT)
    'Vom letzten Lauf aufräumen
    cleanFlps
 
    'Quelltabelle auslesen
    Dim wsSrc As Worksheet: Set wsSrc = ThisWorkbook.Worksheets(C_DATA_SHEET_NAME)
    'Letzte Zeile ermitteln
    Dim lastRowNr&:         lastRowNr = xlsGetLastRow(wsSrc)
    'Anzahl Datenzeilen (ohne Header) berechnen
    Dim dataRows&:          dataRows = lastRowNr - C_HEAD_ROWS
    'Anzahl Flp berechnen
    Dim flpCount&:          flpCount = dataRows \ iFlpSize + 1
    'Der Count-Parameter  muss grösser als 0 sein und kleiner als der Berechnete. Ansonsten wird der Berechnete beibehalten.
    If 0 < iSelectedFlipCount And iSelectedFlipCount < flpCount Then flpCount = iSelectedFlipCount
    'Zeilenanzahl des letzten Flp berechnen
    Dim flpRestSize&:       flpRestSize = dataRows - ((flpCount - 1) * iFlpSize)
 
    'Die einzelnen Flp erstellen
    Dim flpNr&
    For flpNr = 1 To flpCount
        'Neue Tabelle erstellen
        Dim wsFlp As Worksheet:     Set wsFlp = ThisWorkbook.Worksheets.Add
        wsFlp.Name = "FLP_" & flpNr
    
        'Header kopieren
        wsSrc.Range( _
            wsSrc.Cells(1, C_DATA_FIRST_COL), _
            wsSrc.Cells(C_HEAD_ROWS, C_DATA_LAST_COL) _
        ).Copy wsFlp.Range("A1")
    
        'Datenzeilen der Quelle für diesen Flp berechnen
        'Erste Datenzeile
        Dim flpStartRow&:   flpStartRow = (flpNr - 1) * iFlpSize + C_HEAD_ROWS + 1
        'Anzahl Datenzeilen
        Dim flpSize&:       flpSize = IIf(flpNr < flpCount, iFlpSize, flpRestSize)
        'Letzte Datenzeile
        Dim flpEndRow&:     flpEndRow = flpStartRow + flpSize - 1
    
        'Die Datenzeilen kopieren
        wsSrc.Range( _
            wsSrc.Cells(flpStartRow, C_DATA_FIRST_COL), _
            wsSrc.Cells(flpEndRow, C_DATA_LAST_COL) _
        ).Copy wsFlp.Cells(C_HEAD_ROWS + 1, 1)
    Next
 
End Sub

'/**
' * Entfern die Alle Flp-Tabellen
' */
Public Sub cleanFlps()
    Application.DisplayAlerts = False
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name Like "FLP_*" Then ws.Delete
    Next
    Application.DisplayAlerts = True
End Sub


'/**
' * ermitteln der letzten gefüllten Zeile eines Worksheets
' * Die Funktion Sheet.Cells.SpecialCells(xlCellTypeLastCell) liefert auch instanzierte Zeilen ohne Inhalt
' * https://wiki.yaslaw.info/doku.php/vba/excel/functions/getlastrowcol
' * @param  Worksheet               Eine Referenz auf das Worksheet
' * @return Long                    Zeilenindex der letzten Zeile mit Inhalt
' */
Public Function xlsGetLastRow(ByRef Sheet As Excel.Worksheet) As Long
    Dim r As Variant
 
    xlsGetLastRow = Sheet.Cells.SpecialCells(xlCellTypeLastCell).row
    For r = xlsGetLastRow To 1 Step -1
        If Sheet.Application.WorksheetFunction.CountA(Sheet.rows(r)) = 0 Then
            xlsGetLastRow = r - 1
        Else
            Exit For
        End If
    Next r
End Function

Nachtrag:
Ich habe das Program von dem Click-Event getrennt. So kann man das ganze bequem aus dem Direktfenster von VBA testen

createFlps 5

 

[Pr3d4tor]

Ich habe Probleme, dein Code dierkt zu verbessern. Das Thema selber ist aber Interessant. Ich habe mir darum mal die Freiheit genommen, selber einen Code zu schreiben um dieses Problem anzugehen.

Hehe okay,

dafür an dieser Stelle erst einmal vielen Dank für deine Bemühungen.
Eventuell, wenn ich es Zeitlich hinbekomme und unabhängig davon ob mich dein Code weiterbringt oder nicht, werde ich am WE mal schauen ob ich meine Datei so umbasteln kann das ich sie dir dann per PN zu kommen lasse.

Mein Ansatz:

1. Letzter Lauf löschen
2. Berechnen der Anzahl Flp
3. Mit einem Loop durchgehen und diese erstellen

Weitere Erklärungen sind direkt im Code. In der Sub zellenCopyPaste_Click() muss natürlich noch die Form-Eingabe übernommen werden.

Deine Radiobuttons sind überflüssig.

Oookay,

gut zu Wissen das es anscheinend auch ohne geht. Aufgrund deiner ganzen ausführlichen Erklärungen sollte eine Umsetzung kein Problem sein.

Nochmals vielen Dank dafür und sobald ich die Zeit und Ruhe habe werde ich mir das ganze mal anschauen und Testen. Rückmeldung dazu gibts natürlich dann auch von mir...