Data uit verschillende werkboeken in één werkboek plaatsen.

Status
Niet open voor verdere reacties.
J

jands1

Nieuwe gebruiker
Lid geworden
8 dec 2020
Berichten
4
De bedoeling van de macro:
Data uit verschillende werkboeken in één werkboek plaatsen. Alle werkboeken hebben dezelfde sheets en kolommen.

Probleem:
De data vanuit de verschillende werkboeken krijg ik niet gekopieerd. Ik vermoed dat het probleem ligt bij de combinatie For Each en Function Selectionner_Fichiers.
Maar ik loop vast hoe ik dit moet wijzigen. Ondertussen snuister ik verder rond.

Extra info:
De data dient uit de opgegeven worksheets te komen, elk werkboek beschikt nog over andere worksheets.

Code dat ik tot nu toe heb:

HTML: 
Sub Verzamel_data()

Dim N As Workbook
Dim wb As Workbook

Dim IC As Worksheet
Dim IA As Worksheet
Dim EC As Worksheet
Dim EA As Worksheet
Dim vFichiers As Variant 'variabel verschillende excelfiles
Dim Row As Long

Set N = ThisWorkbook

Set IC = Worksheets("Internal Control")
Set IA = Worksheets("Internal Audit")
Set EC = Worksheets("External Control")
Set EA = Worksheets("External Audit")

'Verwijder voorgaande gegevens in nationale file
N.Activate

IC.Select
Row = IC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IC.Range("A7:X" & Row).Clear

IA.Select
Row = IA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IA.Range("A7:X" & Row).Clear

EC.Select
Row = EC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IC.Range("A7:X" & Row).Clear

EA.Select
Row = EA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IA.Range("A7:X" & Row).Clear

'open de gewenste werkboeken
vFichiers = Selectionner_Fichiers("Sélectionner les fichiers à compiler")

'Plaats op te halen gegevens in een loop
For Each wb In Application.Workbooks

'Op te halen gegevens:
'Selecteer gegevens IC en kopieer naar nationale file sheets IC
wb.Activate
Row = IC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IC.Range("A7:X" & Row).Copy
N.Activate
Row = IC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IC.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Selecteer gegevens IA en kopieer naar nationale file sheets IA
wb.Activate
Row = IA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IA.Range("A7:X" & Row).Copy
N.Activate
Row = IA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IA.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Selecteer gegevens EC en kopieer naar nationale file sheets EC
wb.Activate
Row = EC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
EC.Range("A7:X" & Row).Copy
N.Activate
Row = EC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
EC.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Selecteer gegevens EA en kopieer naar nationale file sheets EA
wb.Activate
Row = EA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
EA.Range("A7:X" & Row).Copy
N.Activate
Row = EA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
EA.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Next wb

End Sub
Function Selectionner_Fichiers(sTitre As String) As Variant
Dim sFiltre As String, bMultiSelect As Boolean
 
    sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
    bMultiSelect = True 'Permet de choisir plusieurs fichiers à la fois
    Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)
End Function
 
Ondertussen verder gezocht. Nu doet hij de loop door de files, maar de waarden geraken niet gekopieerd en zie niet wat er verkeerd gaat, ik ken er iets van, maar enkel de basics.

Code: 
Sub Verzamel_data()

Dim fldr As FileDialog
Dim myfolder As String
Dim myFile As String
Dim wbData As Workbook
Dim wbSource As Workbook
Dim IC As Worksheet
Dim IA As Worksheet
Dim EC As Worksheet
Dim EA As Worksheet
Dim Row As Long

Set wbSource = ActiveWorkbook
Set IC = Worksheets("Internal Control")
Set IA = Worksheets("Internal Audit")
Set EC = Worksheets("External Control")
Set EA = Worksheets("External Audit")

'Verwijder voorgaande gegevens in nationale file
IC.Select
Row = IC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IC.Range("A7:X" & Row).Clear

IA.Select
Row = IA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IA.Range("A7:X" & Row).Clear

EC.Select
Row = EC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IC.Range("A7:X" & Row).Clear

EA.Select
Row = EA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
IA.Range("A7:X" & Row).Clear

'selecteer werkboeken waaruit je de dat wenst te kopiëren
 Application.ScreenUpdating = False
    myfolder = "I:\04-SITE\05-All\08-Technology\S-ALL-T-10-NOV-NCF-Doc\NCF Register\test"
    myFile = Dir(myfolder & "\*.xlsm")
    
'Voer acties uit
 Do While myFile <> ""
        Set wbData = Workbooks.Open(myfolder & "\" & myFile)
        'IC
        'Kopieer data
        wbData.Activate
        Row = IC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        IC.Range("A7:X" & Row).Copy
        'Plak in nationale file
        wbSource.Activate
        Row = IC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        IC.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'IA
        wbData.Activate
        Row = IA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        IA.Range("A7:X" & Row).Copy
        wbSource.Activate
        Row = IA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        IA.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'EC
        wbData.Activate
        Row = EC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        EC.Range("A7:X" & Row).Copy
        wbSource.Activate
        Row = EC.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        EC.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        'EA
        wbData.Activate
        Row = EA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        EA.Range("A7:X" & Row).Copy
        wbSource.Activate
        Row = EA.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
        EA.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        myFile = Dir
    Loop

End Sub
 
Dit is nog niet opgelost en geraak voorlopig ook niet verder.
 
misschien zo, met telkens een loopje binnen je 4 werkbladen.
IA,IE, .... bleven altijd verwijzen naar je nationale werkmap, niet naar de nieuw geopende.
Blijft een gokje, want niet getest ....
Kan later misschien nog beknopter, maar wilde je idee behouden !
Hopelijk staat er geen "option explicit" bovenin, anders moet je alle variabelen declareren
Code: 
Sub Verzamel_data()

   Dim fldr    As FileDialog
   Dim myfolder As String
   Dim myFile  As String
   Dim wbData  As Workbook
   Dim wbSource As Workbook
   Dim IC      As Worksheet
   Dim IA      As Worksheet
   Dim EC      As Worksheet
   Dim EA      As Worksheet
   Dim Row     As Long
   Dim Blad, Bladen, shSource, shData

   Bladen = Array("Internal Control", "Internal Audit", "External Control", "External Audit")   '->je 4 bladen

   Set wbSource = ActiveWorkbook

   'Verwijder voorgaande gegevens in nationale file
   For Each Blad In Bladen 'in een loopje de bladen aflopen
      Set sh = wbSource.Sheets(Blad)
      Row = sh.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
      MsgBox sh.Name & vbTab & Row
      sh.Range("A7:X" & Row).Clear
   Next

   'selecteer werkboeken waaruit je de dat wenst te kopiëren
   Application.ScreenUpdating = False
   myfolder = "I:\04-SITE\05-All\08-Technology\S-ALL-T-10-NOV-NCF-Doc\NCF Register\test"
   myFile = Dir(myfolder & "\*.xlsm")

   'Voer acties uit
   Do While myFile <> ""
      Set wbData = Workbooks.Open(myfolder & "\" & myFile)
      'IC
      'Kopieer data
      MsgBox "nieuwe file : " & myFile
      For Each Blad In Bladen
         Set shSource = wbSource.Sheets(Blad)
         Set shData = wbData.Sheets(Blad)
         Row = shData.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
         shData.Range("A7:X" & Row).Copy
         'Plak in nationale file
         Row = shSource.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
         shSource.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Next
      wbData.Close 0 '->die werkmap sluiten zonder opslaan
      myFile = Dir
   Loop

End Sub
 
Laatst bewerkt:
Eerst maar eens in het doelbestand alle werkbladen verzamelen uit andere bestanden. Daarna zien we wel weer verder.

Code: 
Sub M_snb()
  c00 = "I:\04-SITE\05-All\08-Technology\S-ALL-T-10-NOV-NCF-Doc\NCF Register\test\"
  c01 = Dir(c00 & "*.xlsm")
  c02 = "_Internal Control_Internal Audit_External Control_External Audit_"

  Do While c01 <> ""
    With GetObject(c00 & c01)
      For Each it In .Sheets
        If InStr(c02, "_" & it.Name & "_") Then it.Copy , ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
      Next
      .Close 0
    End With

    c01 = Dir
  Loop
End Sub

Als het meteen in het overeenkomstige werkblad gezet moet wqrden:

Code: 
Sub M_snb()
  c00 = "I:\04-SITE\05-All\08-Technology\S-ALL-T-10-NOV-NCF-Doc\NCF Register\test\"
  c01 = Dir(c00 & "*.xlsm")
  c02 = "_Internal Control_Internal Audit_External Control_External Audit_"

  Do While c01 <> ""
    With GetObject(c00 & c01)
      For Each it In .Sheets
        If InStr(c02, "_" & it.Name & "_") Then it.UsedRange.Copy , ThisWorkbook.Sheets(it.Name).Cells(Rows.Count, 1).End(xlUp).Offset(1)
      Next
      .Close 0
    End With

    c01 = Dir
  Loop
End Sub
 
Laatst bewerkt:
dat is dus al direct de "heel" beknopte versie :thumb:
 
Deze code werkt voor mij perfect, dank u voor de hulp.

Ik heb de msg - boxen verwijderd omdat dit voor mij niet echt nodig is.

Code: 
Sub Verzamel_data()

   Dim fldr    As FileDialog
   Dim myfolder As String
   Dim myFile  As String
   Dim wbData  As Workbook
   Dim wbSource As Workbook
   Dim IC      As Worksheet
   Dim IA      As Worksheet
   Dim EC      As Worksheet
   Dim EA      As Worksheet
   Dim Row     As Long
   Dim Blad, Bladen, shSource, shData

   Bladen = Array("Internal Control", "Internal Audit", "External Control", "External Audit")   '->je 4 bladen

   Set wbSource = ActiveWorkbook

   'Verwijder voorgaande gegevens in nationale file
   For Each Blad In Bladen 'in een loopje de bladen aflopen
      Set sh = wbSource.Sheets(Blad)
      Row = sh.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
      sh.Range("A7:X" & Row).Clear
   Next

   'selecteer werkboeken waaruit je de dat wenst te kopiëren
   Application.ScreenUpdating = False
   myfolder = "I:\04-SITE\05-All\08-Technology\S-ALL-T-10-NOV-NCF-Doc\NCF Register\test"
   myFile = Dir(myfolder & "\*.xlsm")

   'Voer acties uit
   Do While myFile <> ""
      Set wbData = Workbooks.Open(myfolder & "\" & myFile)
      'IC
      'Kopieer data
      For Each Blad In Bladen
         Set shSource = wbSource.Sheets(Blad)
         Set shData = wbData.Sheets(Blad)
         Row = shData.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
         shData.Range("A7:X" & Row).Copy
         'Plak in nationale file
         Row = shSource.Cells(Rows.Count, "G").End(xlUp).Offset(1, 0).Row
         shSource.Range("A" & Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
      Next
      wbData.Close 0 '->die werkmap sluiten zonder opslaan
      myFile = Dir
   Loop

End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan