code anpassen
14.09.2007 11:06:09
Jürg
ich habe diesen super guten code bekommen
kann man der noch anpassen mit
checken ob einzufügende tabbelle schon vorhanden ist und
die einzufügende Tabelle an das Ende setzen.
Sub aTest()
'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("Notizen")
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
If boTab1vorhanden = False Then
wksQuelle.Copy Before:=wbZiel.Worksheets(1)
wbZiel.Save
End If
wbZiel.Close savechanges:=False
Datei = Dir
Loop
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
vielhn Dank
es grüsst
jürg