1 Blatt in viele Excelmappen kopieren

[pingpong007]

Hallo zusammen,
ich möchte gerne ein Excelblatt in viele Exceldateien mit VBA kopieren. Die Exceldateien haben unterschiedliche Namen und sind in einem Ordner gespeichert.

Ich habe bereits versucht in den Foren etwas passendes zu finden, aber das Programm bleibt hängen und vielleicht erkennt einer von euch, woran es liegt ... :16:

Vielen lieben Dank vorab...

LG Peter


Das war ein Programm aus 2010

 

Code:

Public Sub Blatt_kopieren()
     Dim WS_kopie As Worksheet
     Dim i As Integer
     Dim WB As Workbook
     Set WS_kopie = ThisWorkbook.Sheets("Musterblatt")
    
     With Application.FileSearch   <------ [b]hier ist das Problem [/b]!!!!

         .NewSearch
         .LookIn = "K:\Test\Mappen"     <--------Hier sind die Mappen gespeichert
         .Filename = ".xlsx"
         .SearchSubFolders = False 
        
         If .Execute > 0 Then
         For i = 1 To .FoundFiles.Count
            
             If .FoundFiles(i) <> ThisWorkbook.FullName Then
             Set WB = Workbooks.Open(Filename:=.FoundFiles(i))
             WS_kopie.Copy after:=WB.Sheets(WB.Sheets.Count)
             WB.ChangeLink Name:=ThisWorkbook.Name, NewName:=WB.Name, Type:=xlExcelLinks
             WB.Close savechanges:=True
             End If
            
         Next i
         Else
         MsgBox "Es wurden keine Exceldateien gefunden.", vbCritical, "Achtung"
         End If
     End With
 End Sub

[00202]

Hallo Peter, :19:

"Application.FileSearch" gibt es in VBA schon lange nicht mehr. :21:

Probiere es mal so:

Code:

Option Explicit
Public Sub Main()
    Dim wkbBook As Workbook
    Dim strFile As String
    Dim strPath As String
    Dim lngCalc As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With
    'Pfad anpassen!!!!!!!!
    strPath = "C:\Temp\Mappe\"
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    strFile = Dir$(strPath & "*.xls*")
    Do While strFile <> ""
        With ThisWorkbook
            If strFile <> .Name Then
                Set wkbBook = Application.Workbooks.Open(strPath & strFile, False)
                .Worksheets("Musterblatt").Copy After:=wkbBook.Worksheets(wkbBook.Worksheets.Count)
                wkbBook.ChangeLink Name:=strPath & ThisWorkbook.Name, NewName:=strPath & wkbBook.Name, Type:=xlExcelLinks
                wkbBook.Close True
                strFile = Dir$()
                Set wkbBook = Nothing
            Else
                strFile = Dir$()
            End If
        End With
    Loop
Fin:
    Set wkbBook = Nothing
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = lngCalc
    End With
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

[pingpong007]

Hallo Case,
erstmal vielen Dank für deine schnelle Rückmeldung.
Ich teste es und melde mich wieder :17:

LG Peter

[pingpong007]

Hallo Case,
ich habe dein Programm getestet und es funktioniert fast....

Vielleicht kannst du den kleinen Haken finden...

Das Programm öffnet im angegebenen Verzeichnis die 1. Excel Datei wie gewünscht - das Musterblatt wird auch in diese Datei kopiert - aber statt die 1. Mappe zu speichern - zu schließen und die 2. Excel Datei zu öffnen gibt es folgende Meldung aus:

Error 1004 Die Methode ChangeLink für das Objekt Workbook ist fehlgeschlagen

Vielleicht kannst du mir helfen dein Programm anzupassen? 

VLG Peter

[00202]

Hallo, :19:

nun - diese Codezeile habe ich ja einfach von dir übernommen. :21:

Aus der Hilfe:

In diesem Beispiel wird davon ausgegangen, dass in der aktiven Arbeitsmappe mindestens eine Formel vorhanden ist, die mit einer anderen Excel-Quelle verknüpft ist.

Siehe hier: :21:

Workbook. ChangeLink-Methode (Excel)...

Wenn du in den Dateien keine Links hast, bzw. den Code zweimal laufen lässt, dann kommt der Fehler.

[pingpong007]

Hallo Case,
super vielen Dank für den Hinweis. Ich habe die Zeile mit dem Link rausgenommen und nun läuft dein Programm :18:

Ich wünsche dir noch einen angenehmen "Rest-Arbeitstag"

LG Peter

[snb]

Wäre es nicht einfacher die neu Datei den Namen der 'alte', verlinkte Datei zu geben ?
Dann stimmen die links zu dieser 'neue' Datei.