wertes forum
ich habe einen tollen code von euch bekommen, nur sollte die eingefügte tabelle immer am schluss sein. kan mir jemand das noch so anpassen?
wäre super
Sub zTest()
'Kopiert Tabelle1 einer Datei in alle Dateien eines Verzeichnisses
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksziel As Worksheet
Dim Datei, Anzahl%, Zaehler%, Verzeichnis, boTab1vorhanden As Boolean
On Error GoTo Fehler
If MsgBox("Tabelle1 aus aktiver Datei kopieren?" & vbLf & vbLf _
& "Bei 'Nein' wird Datei-Öffnen-Dialog angezeigt!", vbQuestion + vbYesNo) = vbYes Then
Set wbQuelle = ActiveWorkbook
Else
'Datei mit zu kopierender Tabelle1 öffnen
Verzeichnis = Application.GetOpenFilename(Filefilter:="Exceldatei(*.xls),*.xls", _
Title:="Bitte Datei mit zu kopierender Tabelle öffnen", MultiSelect:=False)
If Verzeichnis = False Then Exit Sub
Set wbQuelle = Application.Workbooks.Open(Verzeichnis)
End If
Set wksQuelle = wbQuelle.Worksheets("notiz")
Application.ScreenUpdating = False
'Verzeichnis mit Dateien auswählen
Verzeichnis = Application.GetOpenFilename(Filefilter:="Exceldatei(*.xls),*.xls", _
Title:="Bitte Datei im Zielverzeichnis auswählen", MultiSelect:=False)
If Verzeichnis = False Then Exit Sub
Do Until Right(Verzeichnis, 1) = "\"
Verzeichnis = Left(Verzeichnis, Len(Verzeichnis) - 1)
Loop
'Anzahl Dateien im Zielverzeichnis ermitteln für Fortschrittsanzeige in Statuszeile
Datei = Dir(Verzeichnis & "*.xls")
Do Until Datei = ""
Anzahl = Anzahl + 1
Datei = Dir
Loop
'Dateien im Zielverzeichnis öffnen und ggf. Tabelle1 einfügen
Application.DisplayAlerts = False
Datei = Dir(Verzeichnis & "*.xls")
Do Until Datei = ""
Zaehler = Zaehler + 1
Application.StatusBar = "Datei " & Zaehler & " von " & Anzahl & " wird bearbeitet"
Set wbZiel = Application.Workbooks.Open(Datei)
boTab1vorhanden = False
For Each wksziel In wbZiel.Worksheets
If wksziel.Name = "Notizen" Then
boTab1vorhanden = True
Exit For
End If
Next
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
If boNotizenvorhanden = False Then
wksQuelle.Copy Before:=wbZiel.Worksheets(1)
wbZiel.Close savechanges:=True
Else
wksQuelle.Copy After:=wbZiel.Sheets(wbZiel.Sheets.Count)
End If
'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Datei = Dir
Loop
Application.DisplayAlerts = True
Application.DisplayAlerts = True
Application.StatusBar = False
Application.ScreenUpdating = False
Exit Sub
Fehler:
MsgBox "der Fehler Nummer: " & Err.Number & " ist aufgetreten" & vbLf & vbLf _
& Err.Description & vbLf
End Sub
mit gruss
Jürg