Macro til travesere mappe og kopiere indhold internt i de enkelte filer

Ændret i løsningen fra Supertekst fra den anden tråd du linker.

Tager værdien fra A1 og indsætter til B1 i det første Ark i projektmappen.

Dim sti As String, filnavn As String
Dim sysXLS As Workbook, sysNavn As String

Dim divXLS As Workbook
Public Sub tilsætUgedag()
    sti = ActiveWorkbook.Path
    Set sysXLS = ActiveWorkbook
    sysNavn = sysXLS.Name
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.Files
   
Rem traverser den aktuelle mappe - find filer med extension .dat
    For Each f1 In fc
        filnavn = f1.Name
       
        If filnavn <> sysNavn Then
            Workbooks.Open sti & "\" & filnavn
            Set divXLS = ActiveWorkbook
            With divXLS
                .Sheets(1).Range("B1") = .Sheets(1).Range("A1")
               
                .Application.DisplayAlerts = False
                .Save
                .Close
            End With
            Set divXLS = Nothing
        End If
    Next
   
    MsgBox "Gennemløb afsluttet"
End Sub

Tak for hurtigt svar.

Den gør den praktiske del af jobbet som den skal, men melder fejl 400 istedet for at komme beskeden "Gennemløb afsluttet".

Kan du også se løsningen på det?

Hej igen

Prøv med denne her :)
Det ser ud til at det var fordi "hovedarket" var åben og derfor finder den en skjult skrivebeskyttet fil af hovedarket som den så ikke kunne åbne. Det skulle den helst ikke gøre nu :)


Dim sti As String, filnavn As String
Dim sysXLS As Workbook, sysNavn As String

Dim divXLS As Workbook
Public Sub tilsætUgedag()
    sti = ActiveWorkbook.Path
    Set sysXLS = ActiveWorkbook
    sysNavn = sysXLS.Name
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.Files
 
Rem traverser den aktuelle mappe - find filer med extension .dat
    For Each f1 In fc
        filnavn = f1.Name
     
        If filnavn <> sysNavn And InStrRev(filnavn, "$") = 0 Then
            Workbooks.Open sti & "\" & filnavn
            Set divXLS = ActiveWorkbook
            With divXLS
                .Sheets(1).Range("B1") = .Sheets(1).Range("A1")
             
                .Application.DisplayAlerts = False
                .Save
                .Close
            End With
            Set divXLS = Nothing
        End If
    Next
 
    MsgBox "Gennemløb afsluttet"
End Sub

Fremragende! Tak for hjælpen.

Læg venligst et svar.

Super :-) her er et svar