Veel gegevens kopieren uit verschillende excel files, uit verschillende tabbladen

[Kcir]

hallo allemaal,

Ik ben nog nieuw in de VBA-wereld. Ik heb al een hoop gelezen hier op het forum (en andere fora), maar ik heb nog geen oplossing kunnen vinden voor mijn probleem.

Waar ik uiteindelijk naartoe wil is dat ik een bepaald bestandje heb (heet nu nog test.xls) met een tabblad waar ik wat dingen kan invullen voor de macro en 4 andere tabbladen. In die 4 tabbladen moeten gegevens komen te staan uit een reeks .xls-documenten. Ik heb nu een map met ca. 15 bestanden, die allemaal veel tabbladen bevatten. Deze tabbladen hebben allemaal andere namen, behalve de eerste. (die heet index). Nu moet dus uit ieder tabblad van al die bestanden, gegevens gekopieerd worden naar die ene file (test.xls).
Nu heb ik al een deel werkend gekregen. Dat wil zeggen: de macro opent en sluit de bestanden een voor een.

Private Sub test()
    werkboekpad = ThisWorkbook.Sheets("macro").Range("B2")
    Dim objWB As Workbook, sourcepath As String, wbName As String
    sourcepath = werkboekpad
    ChDir sourcepath
    wbName = Dir("*.*")
    With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .AskToUpdateLinks = False

    Do
        On Error Resume Next
        Set objWB = Workbooks.Open(sourcepath & wbName)
        If Err.Number <> 0 Then
            Err.Clear
            With Application
            .AskToUpdateLinks = True
            .DisplayAlerts = True
            .EnableEvents = True
            .sceenupdating = True
            End With
            MsgBox "Er zijn geen files met de xls extensie, in het pad " & vbCrLf & sourcepath & ". ", 48, "Kan niet doorgaan, er is niets te openen"
            Exit Sub
            End If
        
 ' Als het goed is moet hier nu komen te staan dat in ieder tabblad (behalve de eerste) bepaalde cellen gekopieerd worden, en geplakt worden in test.xls

                 [COLOR="red"]Sheets("juiste tabblad").Select
                 Range("D3").Select
                 Selection.Copy
                 Windows("test.xls").Activate
                 Range("C2").Select
                 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                   :=False, Transpose:=False
                Windows("").Activate
                Sheets("").Select
                Range("D3").Select
               Application.CutCopyMode = False
               Selection.Copy
                Windows("test.xls").Activate
                Range("C3").Select
               Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                  :=False, Transpose:=False     [/COLOR] 
      
       
        objWB.Close True               
        
        wbName = Dir
        Loop While wbName <> ""
        .AskToUpdateLinks = True
        .DisplayAlerts = True
        .EnableEvents = True
        .ScreenUpdating = True
        End With
 End Sub

Het rode deel is het deel dat nu niet werkt, en wat ook verder uitgebreid zal moeten worden.
Wie o Wie kan mij helpen!

Groeten,
Rick

 

[Kcir]

Niemand een ideetje?