Am besten wäre es wenn nichts ausgewählt ist das dann alles in Tabelle1 kopiert wird, ist aber nicht ganz so wichtig.
Müsste ich jetzt 15 Makros nehmen und jedem Optionsfeld eines zuweisen oder gibt es da noch andere Wege
?
Gruß
Andre
'Tabelle2 nach 1
Dim wks As Worksheet
Dim rngA As Range
Dim iRow As Integer, iCounter As Long
Set rngA = Worksheets("Tabelle2").Range("A:C").CurrentRegion
Set wks = Worksheets("Tabelle1")
rngA.Range("A:C").CurrentRegion.Copy wks.Range("A:C")
'Tabelle3 nach 1 usw.
Set rngA = Worksheets("Tabelle3").Range("A:C").CurrentRegion
Set wks = Worksheets("Tabelle1")
rngA.Range("A:C").CurrentRegion.Copy wks.Range("A:C")
schön wäre es noch wenn keine chekbox markiert ist das dann alle 15 tabellen eingefügt werden
gruß
andre
Die Datei https://www.herber.de/bbs/user/47164.xls wurde aus Datenschutzgründen gelöscht
Option Explicit
Sub create_XML()
Dim rng As Range
Dim objWS As Worksheet, objAUSGABE As Worksheet
Set objAUSGABE = Sheets("Ausgabe")
If Application.CountIf(Range("L1:L15"), True) = 0 Then Range("L1:L15").Value = True
For Each rng In Range("L1:L15")
If rng = True Then
Set objWS = Sheets("Tabelle" & rng.Row + 1)
objWS.Range("A1:C" & objWS.Cells(Rows.Count, 1).End(xlUp).Row).Copy _
objAUSGABE.Cells(objAUSGABE.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)
End If
Next
objAUSGABE.Rows(1).Delete
' hier bleibt der Code stehen ohne Fehlermeldung
' auch werden die 15 Tabellen richtig ausgefüllt
' erst wenn man ein zweites mal startet werden die ausgewählten
' Blätter in die Ausgabe kopiert aber dann neu überschrieben
Set objWS = Nothing
Set objAUSGABE = Nothing
Set rng = Nothing
End Sub
Sub Check_All()
If Range("L1").Value = True Then
Range("L1:L15").Value = False
Else
Range("L1:L15").Value = True
End If
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Die Datei https://www.herber.de/bbs/user/47186.xls wurde aus Datenschutzgründen gelöscht