AW: tABELLE EINFÜGEN
01.09.2007 19:56:44
fcs
Hallo Jürg,
der folgende Code führt die gewünschte Tabellen-Kopieraktion aus. Die Quell-Datei 4711.xls darf dabei nicht im selben Verzeichnis liegen wie die Zieldateien. Andernfalls müsstest du noch entsprechende Prüfungen einbauen.
Gruß
Franz
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("Tabelle1")
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 = "Tabelle1" 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
'wbQuelle.Close savechanges:=False
Application.StatusBar = False
Application.ScreenUpdating = False
Exit Sub
Fehler:
MsgBox "der Fehler Nummer: " & Err.Number & " ist aufgetreten" & vbLf & vbLf _
& Err.Description & vbLf
End Sub