Schleifenproblem (Oder: Wer hilft mir Ordnung zu schaffen?!)

  • Excel

Es gibt 5 Antworten in diesem Thema. Der letzte Beitrag () ist von Rehripper.

    Schleifenproblem (Oder: Wer hilft mir Ordnung zu schaffen?!)

    Hallo erstmal,
    zum einen einen ganz großen Dank an die Mitwirkenden auf dieser Plattform. Hab mir schon viele Infos holen können, die meine eher Laienhafte VBA Programmierung stark voran getrieben haben.

    Jetzt zum Problem (das eigentlich keins ist!)
    Mit dem angehängten Code wird im Endeffekt entsprechend der Auswahl aus der Userform aus verschiedenen Tabellenblättern der vorhandene Inhalt kopiert und in eine neue Arbeitsmappe geschrieben.
    Der Code funktioniert auch so wie er ist (fast) perfekt.
    Da ich aber gerne noch was lernen möchte nun die Frage:
    Kann ich die Komplette Abfrage der Checkboxen nicht in eine Schleife packen, um auch eine eventuell spätere Nachbearbeitung zu vereinfachen?
    Ich habs versucht und bin vollkommen gescheitert... :(
    Das einzige was auch in diesem Code nicht immer (mal schon, mal nicht) funktioniert, ist das die Zeilenhöhe der Überschrift nicht im Format übernommen wird und dann zusammengeschoben ist.

    Ich wäre dankbar, wenn ihr mir beim Code helfen würdet und gerne auch mit einer kurzen Erklärung...
    Möchte es gerne verstehen...!!

    Vielen Dank im Voraus! :)

    VB.NET-Quellcode

    1. Private Sub Erstellen_Click()
    2. Dim gbis As Date
    3. 'Kopfzeile befüllen
    4. If Me.Betr = "" Then
    5. MsgBox ("Bitte Kürzel eingeben")
    6. Exit Sub
    7. Else
    8. Worksheets("Preisliste").Range("F1") = Me.Betr
    9. End If
    10. If Me.KDNummer = "" Then
    11. MsgBox ("Bitte eine Kundennummer eingeben")
    12. Exit Sub
    13. Else
    14. Worksheets("Preisliste").Range("B3") = Me.KDNummer
    15. End If
    16. If Me.KDName = "" Then
    17. MsgBox ("Bitte einen Kundennamen eingeben")
    18. Exit Sub
    19. Else
    20. Worksheets("Preisliste").Range("B4") = Me.KDName
    21. End If
    22. If Me.Guelt_Ab = "" Then
    23. MsgBox ("Bitte Gültiges Datum oder Format eingeben!")
    24. Exit Sub
    25. Else
    26. If Me.Guelt_Ab.Value = Format(CDate(Guelt_Ab.Value), "dd.mm.yyyy") Then
    27. gbis = Format(CDate(Me.Guelt_Ab.Value), "yyyy")
    28. Worksheets("Preisliste").Range("F3") = Me.Guelt_Ab
    29. Worksheets("Preisliste").Range("F4") = DateSerial(gbis, 12, 31)
    30. Else
    31. MsgBox ("Bitte Gültiges Datum oder Format eingeben!")
    32. End If
    33. End If
    34. 'Checkboxen abfragen und in die leere Vorlage kopieren
    35. If Me.CB_RTC_Tag.Value = True Then
    36. Worksheets("RTC_Tag").Range("A1:F" & Sheets("RTC_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    37. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    38. End If
    39. If Me.CB_RTC_Bed.Value = True Then
    40. Worksheets("RTC_Bed").Range("A1:F" & Sheets("RTC_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    41. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    42. End If
    43. If Me.CB_RTL_75_Tag.Value = True Then
    44. Worksheets("RTL_Tag").Range("A1:F" & Sheets("RTL_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    45. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    46. End If
    47. If Me.CB_RTL_75_Bed.Value = True Then
    48. Worksheets("RTL_Bed").Range("A1:F" & Sheets("RTL_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    49. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    50. End If
    51. If Me.CB_RTL_U75_Tag.Value = True Then
    52. Worksheets("RTL_U75_Tag").Range("A1:F" & Sheets("RTL_U75_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    53. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    54. End If
    55. If Me.CB_RTL_U75_Bed.Value = True Then
    56. Worksheets("RTL_U75_Bed").Range("A1:F" & Sheets("RTL_U75_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    57. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    58. End If
    59. If Me.CB_RTL_Kom_Tag.Value = True Then
    60. Worksheets("Kommunal_Tag").Range("A1:F" & Sheets("Kommunal_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    61. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    62. End If
    63. If Me.CB_RS_Tag.Value = True Then
    64. Worksheets("RS_Tag").Range("A1:F" & Sheets("RS_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    65. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    66. End If
    67. If Me.CB_RGT_Tag.Value = True Then
    68. Worksheets("RGT_Tag").Range("A1:F" & Sheets("RGT_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    69. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    70. End If
    71. If Me.CB_RST_Tag.Value = True Then
    72. Worksheets("RST_Tag").Range("A1:F" & Sheets("RST_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    73. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    74. End If
    75. If Me.CB_RTR_Light_Tag.Value = True Then
    76. Worksheets("RTR_Light_Tag").Range("A1:F" & Sheets("RTR_Light_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    77. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    78. End If
    79. If Me.CB_RTR_Light_Bed.Value = True Then
    80. Worksheets("RTR_Light_Bed").Range("A1:F" & Sheets("RTR_Light_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    81. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    82. End If
    83. If Me.CB_RTR_RT_Tag.Value = True Then
    84. Worksheets("RTR_RT_Tag").Range("A1:F" & Sheets("RTR_RT_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    85. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    86. End If
    87. If Me.CB_RTR_RT_Bed.Value = True Then
    88. Worksheets("RTR_RT_Bed").Range("A1:F" & Sheets("RTR_RT_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    89. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    90. End If
    91. If Me.CB_RTA_Tag.Value = True Then
    92. Worksheets("RTA_Tag").Range("A1:F" & Sheets("RTA_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    93. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    94. End If
    95. If Me.CB_RMB_Tag.Value = True Then
    96. Worksheets("RMB_Tag").Range("A1:F" & Sheets("RMB_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    97. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    98. End If
    99. If Me.CB_RMS_Tag.Value = True Then
    100. Worksheets("RMS_Tag").Range("A1:F" & Sheets("RMS_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    101. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    102. End If
    103. If Me.CB_RTS_Starr_Tag.Value = True Then
    104. Worksheets("RTS_Starr_Tag").Range("A1:F" & Sheets("RTS_Starr_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    105. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    106. End If
    107. If Me.CB_RTS_Roto_Tag.Value = True Then
    108. Worksheets("RTS_Roto_Tag").Range("A1:F" & Sheets("RTS_Roto_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    109. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    110. End If
    111. If Me.CB_Transport_Tag.Value = True Then
    112. Worksheets("Transport_Tag").Range("A1:F" & Sheets("Transport_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    113. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    114. End If
    115. If Me.CB_Transport_Bed.Value = True Then
    116. Worksheets("Transport_Bed").Range("A1:F" & Sheets("Transport_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    117. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    118. End If
    119. If Me.CB_Kran_Tag.Value = True Then
    120. Worksheets("Kran_Tag").Range("A1:F" & Sheets("Kran_Tag").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    121. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    122. End If
    123. 'Fußzeilen einfügen
    124. Worksheets("TK_Tieflader").Range("A1:F" & Sheets("TK_Tieflader").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    125. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    126. Worksheets("TK_LKW_Anh").Range("A1:F" & Sheets("TK_LKW_Anh").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    127. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    128. Worksheets("TK_Stapler").Range("A1:F" & Sheets("TK_Stapler").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    129. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    130. Worksheets("FZ_Allg").Range("A1:F" & Sheets("FZ_Allg").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    131. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    132. Worksheets("FZ_Selbstf").Range("A1:F" & Sheets("FZ_Selbstf").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    133. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    134. Worksheets("FZ_Bed").Range("A1:F" & Sheets("FZ_Bed").UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    135. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    136. 'Tabelle 1 in neue Mappe kopieren und speichern
    137. Call TabCopy
    138. End Sub
    139. Sub TabCopy()
    140. Dim vntBlattName As Variant
    141. Dim strWkbName As String
    142. Dim strPfad As String
    143. strPfad = "H:\"
    144. strWkbName = Format(CDate(Me.Guelt_Ab), "yyyy") & "-SP-" & Me.KDName & "-" & Me.KDNummer & "-" & Me.Betr
    145. vntBlattName = ("Preisliste")
    146. Sheets(vntBlattName).Copy
    147. ActiveWorkbook.SaveAs strPfad & strWkbName
    148. 'ActiveWorkbook.Close
    149. Workbooks("SP_Liste_Generator.xlsm").Activate
    150. Application.Visible = True
    151. Worksheets("Preisliste").Range("A6:F1000").Delete
    152. ActiveWorkbook.Save
    153. Workbooks("SP_Liste_Generator.xlsm").Close
    154. End Sub

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Rehripper“ ()

    Ich würde das so machen (bin kein VBA Coder, kann Syntaxfehler enthalten):

    Visual Basic-Quellcode

    1. Dim sheetsToBeCopied(100) As String
    2. Dim index As Integer = 0
    3. If Me.CB_RGT_Tag.Value Then
    4. sheetsToBeCopied(index) = "RGT_Tag"
    5. index += 1
    6. End If
    7. If Me.RTR_RT_Tag.Value Then
    8. sheetsToBeCopied(index) = "RTR_RT_Tag"
    9. index += 1
    10. End If
    11. '........
    12. For Each sheet In sheetsToBeCopied
    13. Worksheets(sheet).Range("A1:F" & Sheets(sheet).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    14. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    15. Next


    -- Wäre alles einfacher mit Dictionaries oder LINQ, aber sowas kenn ich in VBA nicht, das wäre schonmal ein Anfang. Wenn es dynamische Auflistungen gibt, kann man sich das mit "index" auch schenken, ich hab keine Ahnung.

    EDIT: Letztendlich wird davon dein Code ja auch nicht kürzer, nur übersichtlicher. Wenn eswas gibt, mit dem du die ComboBox und dessen zugehörigen Sheetnamen in Verbindung bringen kannst (Dictionaries halt, HashTables whatever), dann sag Bescheid, dann kann man das richtig kürzen ;D
    »There's no need to "teach" atheism. It's the natural result of education without indoctrination.« — Ricky Gervais
    Gut ich hab mal gegooglet, das kam bei mir raus, ich bezweifle, dass es kompiliert, aber die Idee sollte deutlich werden:

    Visual Basic-Quellcode

    1. Dim cbSheetDict As Dictionary
    2. Set cbSheetDict = New Dictionary
    3. 'Alle Relationen hinzufügen
    4. cbSheetDict.Add "RGT_Tag", CB_RGT_Tag
    5. cbSheetDict.Add "RTR_RT_Tag", CB_RTR_RT_Tag
    6. '....
    7. 'Alle CBs durchgehen
    8. Dim sheetsToBeCopied As Collection
    9. For Each sheet in cbSheetDict.Keys
    10. If cbSheetDict.Item(sheet).Value Then
    11. sheetsToBeCopied.Add sheet
    12. End If
    13. Next
    14. For Each sheet In sheetsToBeCopied
    15. Worksheets(sheet).Range("A1:F" & Sheets(sheet).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    16. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    17. Next
    »There's no need to "teach" atheism. It's the natural result of education without indoctrination.« — Ricky Gervais
    Hey,

    du könntest alle Controls der Form durchlaufen. Jede Checkbox die relevant ist bekommt als Tag den Namen des Worksheets, welches es zu kopieren gilt:

    Visual Basic-Quellcode

    1. Dim ctl As Object
    2. For Each ctl In Me.Controls
    3. If UCase(TypeName(ctl)) = "CHECKBOX" Then
    4. If ctl.Value and ctl.tag <>"" Then
    5. Worksheets(ctl.Tag).Range("A1:F" & Sheets(ctl.Tag).UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Copy _
    6. Destination:=Worksheets("Preisliste").Range("A" & Sheets("Preisliste").Cells(Rows.Count, 1).End(xlUp).Row + 2)
    7. End If
    8. End If
    9. Next ctl


    So kannst du einfach Checkboxen hinzufügen und der Code bleibt der gleiche, solange die Kopierlogik die gleiche ist.
    Gruß Murdoc
    Hallo zusammen,
    danke erstmal für die vielen Ansätze... da wäre ich so nicht drauf gekommen! :)

    @Murdoc deinen Ansatz habe ich übernommen. Nur ein paar Tags eingefügt und schon läuft das Ding perfekt!
    Und das beste: Ich hab es sogar verstanden! Darum ging es ja!

    Also tausend Dank nochmal für eure Mühen!

    Problem gelöst! :thumbsup: