tabblad uit 1 werkmap kopieren naar overige werkmappen in zelfde map

[Bigbrains]

Goedemiddag allen,

Ik ben op zoek naar de mogelijkheid om 1 tablad (genaamd Samenvatting) uit 1 excel werkmap automatisch te kopieren naar alle andere werkmappen in dezelfde folder.

Eigenlijk dus de tab-copy functie maar dan zonder dat ik dat voor de 400 afzonderlijke excel bestanden hoef te doen. In het tabblad Samenvatting staan overigens wel formules die het ook in de nieuwe werkmappen moeten doen.

Ik kom er zelf niet uit, misschien dat iemand van jullie mij op wek kan helpen.
Alvast bedankt.

Gr
Jonas

 

[HSV]

Test het maar eens Jonas,

Sub hsv()
Dim bestandopen As String
Application.ScreenUpdating = False
 bestandopen = Dir(ThisWorkbook.Path & "\*")
    Do Until bestandopen = ""
     If bestandopen <> ThisWorkbook.Name Then
        Workbooks.Open ThisWorkbook.Path & "\" & bestandopen
        ActiveWorkbook.Sheets.Add(, Sheets(Sheets.Count)).Name = "samenvatting"
        ThisWorkbook.Sheets("samenvatting").UsedRange.Copy ActiveWorkbook.Sheets("samenvatting").Range("a1")
        Workbooks(bestandopen).Close True
      End If
    bestandopen = Dir
  Loop
End Sub

 

[Bigbrains]

Harry, dank hiervoor.

Helaas lukt het nog niet, ik doe waarschijnlijk iets verkeerds. Hieronder een beschrijving van ik dit aanpak.

1. Ik heb de code die je hebt gestuurd als macro ingevoegd.
2. De andere bestanden in dezelfde map heb ik niet openstaan.
3. vervolgens voer ik de macro uit het bijgevoegde bestand, ik krijg dan wel pop-up schermen die verwijzen naar de andere bestanden in de map met de melding of ik de wijzigingen wil opslaan.
4. Ik druk op ok (wijzigingen opslaan). Als ik vervolgens de bestanden open is er geen tabblad toegevoegd.

 

[HSV]

Vreemd, werkt hier als een tierelier.


1: In een standaard module?
2: Moet ook niet.
3: Met Alt+F8 ,3a: Zou je normaal geen melding van moeten krijgen.
4: Opslaan gaat automatisch.

Heb je het bestand opgeslagen voordat je de macro uitvoerde?

 

[Bigbrains]

Hai Harry,

Bij mij werkt het nog niet als een tierelier helaas, maar het goede nieuws het werkt wel

Als ik nu de macro uitvoer op normale wijze, ALt + F8 dan wordt het tabblad samenvatting toegevoegd aan de andere bestanden.
Als ik de dialoogvensters die vragen of ik het bestand wil opslaan vervolgens wegklik (kruisjes), dan wordt het tabblad toegevoegd.

Dit is niet handig, maar zou ik eventueel nog mee kunnen leven. Ander probleem is dat formules in het tabblad samenvatting vervolgens een verwijzing hebben naar het originele bestand.

ik krijg dan: ='H:\test\[test_macro.xlsm]Blad1'!$A$1

terwijl ik zou willen krijgen: Blad1'!$A$1


Bekijk bijlage test_macro.xlsm

 

[HSV]

Zo beter Jonas?

Sub hsv()
Dim bestandopen As String
Application.ScreenUpdating = False
 bestandopen = Dir(ThisWorkbook.Path & "\*")
    Do Until bestandopen = ""
     If bestandopen <> ThisWorkbook.Name Then
     Application.DisplayAlerts = False
        Workbooks.Open ThisWorkbook.Path & "\" & bestandopen
           ActiveWorkbook.Sheets.Add(, Sheets(Sheets.Count)).Name = "samenvatting"
   ThisWorkbook.Sheets("samenvatting").UsedRange.Copy
          With ActiveWorkbook
            .Sheets("samenvatting").PasteSpecial
            .ChangeLink ThisWorkbook.FullName, ActiveWorkbook.FullName, 1
          End With
        Workbooks(bestandopen).Close True
        Application.DisplayAlerts = True
      End If
    bestandopen = Dir
  Loop
  Application.CutCopyMode = False
End Sub

 

[Bigbrains]

Hai Harry,

Ja, het blad wordt nu perfect gekopieerd en ook de formules lopen goed.
Alleen, krijg ik dus wel nog steeds een dialoogscherm te zien . Zou dat iets met mijn excel of computerinstellingen te maken kunnen hebben. Het zou natuurlijk mooier zijn als ik niet alle bestandjes weer apart hoef op te slaan.

 

[HSV]

Is het te kopiëren blad een type .xlsx die je in een .xls bestand invoegt?

 

[Bigbrains]

Hai Harry, nee beide bestanden zijn hetzelfde formaar, namelijk .xlsm

 

[HSV]

Wat voor dialoogvenster komt er tevoorschijn?

edit: misschien een kleine aanpassing.

Sub hsv()
Dim bestandopen As String
 Application.DisplayAlerts = False
 Application.ScreenUpdating = False
 bestandopen = Dir(ThisWorkbook.Path & "\*")
    Do Until bestandopen = ""
     If bestandopen <> ThisWorkbook.Name Then
            Workbooks.Open ThisWorkbook.Path & "\" & bestandopen
           ActiveWorkbook.Sheets.Add(, Sheets(Sheets.Count)).Name = "samenvatting"
   ThisWorkbook.Sheets("samenvatting").UsedRange.Copy
          With ActiveWorkbook
            .Sheets("samenvatting").PasteSpecial
            .ChangeLink ThisWorkbook.FullName, ActiveWorkbook.FullName, 1
          End With
        Workbooks(bestandopen).Close True
      End If
    bestandopen = Dir
  Loop
  Application.CutCopyMode = False
  Application.DisplayAlerts = True
End Sub

 

[Bigbrains]

Hai ik krijg een dialoogvenster van excel met de melding: Do you want to save the changes to [naam ander excelbestand]?

Als ik ja of nee kies dan sluit het excelbestand zonder dat het tabblad is toegevoegd. Pas als ik cancel druk dan blijft het bestand open staan en als ik deze daarna opsla is het tabblad toegevoegd.

 

[HSV]

Hoi,

Helaas kan ik het niet reproduceren.
Displayalerts staat uit (Je zou geen meldingen moeten krijgen):

Displayalerts = false

Savechange staat op true (Het bestand wordt opgeslagen zonder melding):

Workbooks(bestandopen).Close True

Probeer het laatste eens met:

Activeworkbook.close True

Waar ik vermoed dat het niets uithaalt.