Tabellenblatt in 5000 xls kopieren
Stefan
habe ein Problem mit dem ich nicht mehr weiter komme.
Habe in einem Ordner ca.5000 Excellisten.
Möchte nun über ein Macro dieses Tabellenblatt in alle 5000 xls reinkopieren...
Habe so was ähnliches mit Einträgen in ein Tabellenblatt schon mal bekommen.
Kann es leider nicht für ein komplettes Tabellenblatt umschreiben.
Wer ist in VBA so fitt, dass er mir da unter die Arme greifen könnte ?
Vielen Dank schon mal vorab...
Stefan
Hier der Code den es umzuschreiben gilt...
Sub schreibe_in_Arbeitsmappen()
Application.ScreenUpdating = False
Dim wb As Workbook
Dim shFiles As Worksheet
Dim vAdresse, vValue, vTable As String
vTable = ActiveSheet.Name
Dim vPath As String
vPath = "C:\Temp\Test\"
Set wb = ThisWorkbook
fb = False
Call DateienAuslesen(vPath, wb.Name)
Set shFiles = wb.Sheets("Dateiliste")
Sheets(vTable).Select
vAdresse = ActiveCell.Address
vValue = ActiveCell.Value
For Each d In shFiles.Range("A1:A" & shFiles.Cells(Rows.Count, 1).End(xlUp).Row)
Workbooks.Open Filename:=vPath & d
On Error GoTo fb_schreiben
Sheets(vTable).Range(vAdresse) = vValue
If fb = True Then
lz = wb.Sheets("Logbuch").Cells(Rows.Count, 1).End(xlUp).Row + 1
wb.Sheets("Logbuch").Cells(lz, 1) = Now()
wb.Sheets("Logbuch").Cells(lz, 2) = "Daten nicht geschrieben in:"
wb.Sheets("Logbuch").Cells(lz, 3) = d
End If
ActiveWorkbook.Close savechanges:=True
Next
Application.DisplayAlerts = False
shFiles.Delete
Application.DisplayAlerts = True
Exit
Sub
fb_schreiben:
fb = True
Resume Next
End
Sub
Sub DateienAuslesen(vPath, wbName As String)
Dim fs, f, f1, fc, i
On Error Resume Next
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Dateiliste"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(vPath)
Set fc = f.Files
i = 0
For Each f1 In fc
If Right(f1.Name, 4) = ".xls" And f1.Name wbName Then
i = i + 1
ActiveSheet.Cells(i, 1) = f1.Name
End If
Next
End Sub