Excel-waarden uit verschillende bestanden kopiëren naar één bestand?

[StijnVL]

Dag allemaal

Ik heb een map met daarin een 50-tal Excelbestanden (evaluaties van studenten; 1 bestand per student). Uit deze bestanden wil ik bepaalde data bundelen in één bestand. Ik wil dus:

• Bestand 1 uit de map openen en daaruit:
  • Cel B5 copy-pasten naar A1 in “Doelbestand”
  • Cel B8 copy-pasten naar B1 in “Doelbestand”
  • Cel B12 copy-pasten naar C1 in “Doelbestand”
• Bestand 1 uit de map afsluiten en volgende bestand in de map (Bestand 2) openen en daaruit idem:
  • Cel B5 copy-pasten naar A2 in “Doelbestand”
  • Cel B8 copy-pasten naar B2 in “Doelbestand”
  • Cel B12 copy-pasten naar C2 in “Doelbestand”
• Volgende bestand,
• Volgende bestand,
• Tot het laatste bestand uit de map gedaan is.

Hopelijk kunnen jullie me op weg helpen?
Alvast bedankt om mee te denken!
Stijn

 

[edmoor]

Dat kan bijvoorbeeld zo.
Plaats de knop op het werkblad waar je B5, B8 en B12 hebt gevuld.

Private Sub CommandButton1_Click()
    Pad = "E:\Helpmij\StijnVL" '<- hier het pad aanpassen
  
    Application.ScreenUpdating = False
    bst = Dir(Pad & "\*.xls*")
    While bst <> ""
        If bst <> ThisWorkbook.Name Then
            Set swb = Workbooks.Open(Pad & "\" & bst)
            With swb.Sheets("Blad1")
                .Range("A2") = Range("B5")
                .Range("B2") = Range("B8")
                .Range("C2") = Range("B12")
            End With
            swb.Close True
        End If
       bst = Dir()
    Wend
    Application.ScreenUpdating = True
    MsgBox "Gereed", vbInformation
End Sub

Of wil je data uit die bestanden naar het hoofdbestand op meerdere regels hebben?
Dat is dan een simpele aanpassing.

 

[peter59]

Of misschien iets voor power query.

 

[StijnVL]

Hey edmoor

Heel hard bedankt voor je snelle antwoord. Het is al een heel begin, en ik heb zitten sleutelen maar ik vrees dat mijn VBA-kennis nog te beperkt is. (Maar via deze weg leer ik ongetwijfeld veel bij!)

Lang verhaal kort: het is inderdaad zoals u schrijf onder uw code. Ik wens de data uit alle bestanden (een 50-tal) op meerdere regels in het "hoofdbestand". Het lijkt me dan ook 't meest logische om de knop/code in het hoofdbestand te zetten, toch?

 

[StijnVL]

Of misschien iets voor power query.

Moeten de bronbestanden (dus alle bestanden WAARUIT data gekopieerd moet worden) dan al niet opgemaakt zijn als effectieve tabel? Kan je via een power query enkel een paar cellen laten selecteren en kopiëren naar een ander "hoofdbestand"?

 

[edmoor]

Doe het dan zo:

Private Sub CommandButton1_Click()
    Pad = "E:\Helpmij\StijnVL" '<- hier het pad aanpassen
    rgl = 2
 
    Application.ScreenUpdating = False
    bst = Dir(Pad & "\*.xls*")
    While bst <> ""
        If bst <> ThisWorkbook.Name Then
            Set swb = Workbooks.Open(Pad & "\" & bst)
            With swb.Sheets("Blad1") '<- Eventueel bladnaam aanpassen
                Cells(rgl, 1) = .Range("B5")
                Cells(rgl, 2) = .Range("B8")
                Cells(rgl, 3) = .Range("B12")
                Cells(rgl, 4) = swb.Name
            End With
            rgl = rgl + 1
            swb.Close True
        End If
       bst = Dir()
    Wend
    Application.ScreenUpdating = True
    MsgBox "Gereed", vbInformation
End Sub

Regels in het hoofdbestand worden vanaf regel 2 in de kolommen A, B, C, en D overschreven.

P.S.
Vriendelijk, maar je hoeft tegen mij geen u te zeggen

 

[StijnVL]

Als ik deze code invoeg, doet hij nog steeds niet helemaal niet wat ik wil... De code kopieert telkens binnen 1 bronbestand de waardes uit de desbestreffende cellen naar een rij binnen datzelfde bronbestand.

De waardes van de verschillende cellen in de het bronbestand worden dus niet geplakt in het doelbestand (en dan volgende bestand in de volgende rij van het doelbestand, enz)

DUS: wat de code nu doet:
Bestand 1 openen en waardes uit verschillende cellen in kolom B van bestand 1 plakken over verschillende cellen op rij 2.
Daarna:
Bestand 2 openen en waardes uit verschillende cellen in kolom B van bestand 2 plakken over verschillende cellen op rij 3.
Daarna:
Bestand 3 openen en waardes uit verschillende cellen in kolom B van bestand 3 plakken over verschillende cellen op rij 4.
ENZOVOORT


Hopelijk kan je wat opmaken uit mijn beschrijving? Zoniet, alvast m'n excuses, en dan lees ik het wel.

 

[StijnVL]

Waar ik nu mee worstel is eigenlijk dat de code telkens moet terugkeren naar het DOELbestand... Bij wijze van spreken:

Kopieer een cel uit bronbestand en plak in doelbestand.
Kopieer een andere cel uit bronbestand en plak in doelbestand (zelfde rij).
Kopieer nog een andere cel uit bronbestand en plak in doelbestand (zelfde rij)
Sluit bronbestand af, en open het volgende bronbestand.
Kopieer een cel uit bronbestand en plak in doelbestand (volgende rij)
Kopieer een andere cel uit bronbestand en plak in........(volgende rij)

enzovoort enzoverder.

 

[edmoor]

Wat ik plaatste doet exact wat je vroeg.
Wat is je bronbestand en wat is je doelbestand?
Dat is mij niet dan nu duidelijk.

 

[StijnVL]

Oké, sorry als m'n uitleg niet duidelijk was voor je.
Bronbestanden zijn ca. 50 verschillende bestanden in één map. Van daaruit wil ik van elk bestand bv. cel B2, B3 e, B4 kopiëren naar EEN doelbestand in één rij per bronbestand.

In het doelbestand zouden dus 50 rijen moeten ontstaan met daarin telkens de waarden B2, B3 en B4 uit de respectievelijke bronbestanden...

Hopelijk ben ik nu duidelijker? Zoniet, lees ik het wel.

 

[edmoor]

Dat is wat de code in #6 doet.
Plaats eens een gezipte map met wat voorbeeld bestanden.

 

[StijnVL]

Ziehier.

 

[HSV]

Onderstaand stukje aanpassen @edmoor:

Cells(rgl, 1) = .Range("B5")
                Cells(rgl, 2) = .Range("B8")
                Cells(rgl, 3) = .Range("B12")
                Cells(rgl, 4) = swb.Name

en de 'close' op false

 

[jverkerk]

Zo met power query.
Zet alle bestanden in één map, niet het doelbestand.
Alle bestanden moeten er hetzelfde uitzien.
Zet in het bron bestand de verwijzing naar de map waar de bestanden staan in de Editor.

 

[Warme bakkertje]

En nog eentje.

Sub ConsolidateAll()
    Dim rsCon As Object, rsData As Object, sFileName As String
    Dim vdata, i As Long
    ReDim temp(1 To 50, 1 To 3): x = 1
    
    Const wDir = "D:\My Storage\": sFileName = Dir(wDir & "*.xlsx")
    
    Do While sFileName <> ""
        If sFileName <> ThisWorkbook.Name Then
            Set rsCon = CreateObject("ADODB.Connection"): Set rsData = CreateObject("ADODB.Recordset")
            rsCon.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                    wDir & sFileName & ";Extended Properties=""Excel 12.0;HDR=No"";"
            rsData.Open "SELECT * FROM [Sheet1$B3:B5];", rsCon, 0, 1, 1
            vdata = rsData.GetRows(10)
            For i = 0 To UBound(vdata, 2)
                temp(x, i + 1) = vdata(0, i)
            Next i
            x = x + 1: rsData.Close: Set rsData = Nothing: rsCon.Close: Set rsCon = Nothing
            sFileName = Dir
        End If
    Loop
    Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(temp), 3) = temp
End Sub

 

[snb]

Na aanpassing van het pad

Sub M_snb()
   redim sp(100,2)
   c00="G:\OF\"
   c01 =dir(c00 & "*.xlsx)

   do until c01=""
      with getobject(c01).sheets(1)
         sp(n,0)=.cells(3,2)
         sp(n,1)=.cells(4,2)
         sp(n,2)=.cells(5,3)
         .Parent.close 0
     end with
     n=n+1
     c01=Dir
   loop

   sheets(1).cells(1,2).resize(ubound(sp),3)=sp
End Sub

 

[Warme bakkertje]

Na enkele aanpassingen een werkende versie. LOL

Sub M_snb()
    ReDim sp(100, 2)
    c00 = "D:\My Storage\" '<--aanpassen naar juiste directorynaam
    c01 = Dir(c00 & "*.xlsx")
    Application.ScreenUpdating = False
    Do Until c01 = ""
        With GetObject(c00 & c01).Sheets(1)
            sp(n, 0) = .Cells(3, 2)
            sp(n, 1) = .Cells(4, 2)
            sp(n, 2) = .Cells(5, 2)
            .Parent.Close 0
        End With
        n = n + 1
        c01 = Dir
    Loop
    Sheets(1).Cells(1, 2).Resize(UBound(sp), 3) = sp
End Sub

 

[snb]

@WB

Geslaagd voor je VBA-examen. !
Toch nog een punt van je score afgetrokken vanwege de overbodige Application.sreenupdating.

 

[Warme bakkertje]

@snb
Een halfje dan want is toch iets rustiger voor de ogen met de Screenupdating op FALSE.