telkens 2 velden kopiëren uit bijna 700 excelbestanden naar 1 nieuw excel bestand

[trebie]

Hallo,

Ik heb voor 700 personen een berekening in Excel gemaakt. 1 berekening per persoon, dus 700 losse Excelbestanden.

Nu wil ik uit elk los bestand 2 cellen kopiëren in 1 nieuw totaal Excelblad.
De te kopiëren cellen staan op een vaste plaats in elk los Excelbestand, namelijk cel E1 en cel E67.
De inhoud hiervan wil ik in 1 nieuw Exceldocument plaatsen in 2 kolommen.
Dus het nieuwe Excelbestand krijgt 700 regels in de 1e kolom (namelijk alle E1 inhoud) en 700 regels in de 2e kolom (namelijk alle E67 inhoud).

Is dit door middel van VBA op te lossen en zo ja, hoe?

Ik zou enorm geholpen zijn als bovenstaande gaat lukken!!

Met vriendelijke groet,

Trebie

 

[OctaFish]

En staan alle 700 bestanden in één (dezelfde dus) map? En staan er geen andere (Excel) bestanden in die map?

 

[SjonR]

Als er inderdaad geen andere bestanden staan, zou dit moeten werken. Ik heb het helaas niet op 700 bestanden kunnen testen, want ik heb geen 700 bestanden met zelfde indeling. Of je moet even je 700 bestanden als voorbeeldje plaatsen

Sub zevenhonderd()
    Dim SummarySheet As Worksheet
    Dim FolderPath As String
    Dim SelectedFiles() As Variant
    Dim NRow As Long
    Dim FileName As String
    Dim NFile As Long
    Dim WorkBk As Workbook
    Dim SourceRange As Range
    Dim DestRange As Range
    Dim SourceRange2 As Range
    Dim DestRange2 As Range
    
    Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    
    'Hier moet je je eigen map invullen
    FolderPath = "C:\test"
    
    
    ChDrive FolderPath
    ChDir FolderPath
  
    SelectedFiles = Application.GetOpenFilename( _
        filefilter:="Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    
    NRow = 1
      
    
    For NFile = LBound(SelectedFiles) To UBound(SelectedFiles)
        FileName = SelectedFiles(NFile)
        
        Set WorkBk = Workbooks.Open(FileName)
           

        Set SourceRange = WorkBk.Worksheets(1).Range("E1")
        Set SourceRange2 = WorkBk.Worksheets(1).Range("E67")
        Set DestRange = SummarySheet.Range("A" & NRow)
        Set DestRange2 = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, _
           SourceRange.Columns.Count)
        Set DestRange2 = DestRange2.Resize(SourceRange2.Rows.Count, _
           SourceRange2.Columns.Count)
    
        DestRange.Value = SourceRange.Value
        DestRange2.Value = SourceRange2.Value
        
        NRow = NRow + DestRange.Rows.Count
                
        WorkBk.Close savechanges:=False
    Next NFile
        
    
    SummarySheet.Columns.AutoFit
End Sub

 

[snb]

Ik denk dat je beter eerst die 700 bestanden in 1 bestand kunt integreren.
Uit je info blijkt ieder bestand nl. maar 1 werkblad te hebben, met een zeer beperkt bereik van 67 regels en 5 kolommen....

 

[Roncancio]

700 Bestanden openen en uitlezen is niet handig.
Beter is om de bestanden uit te lezen via ExecuteExcel4Macro en desnoods de gegevens in een array schrijven.
Vervolgens kan je de array in een werkblad plaatsen.

Met vriendelijke groet,


Roncancio

 

[SjonR]

En hoe doe je dat dan precies?

 

[OctaFish]

Zoiets bijvoorbeeld:

    wbPath = "H:\Mijn documenten\"
    MijnBestand = Dir(wbPath & "*.xl*")
    wsName = "Blad1"
    cellRef = "A1"
    
    Do While MijnBestand <> ""
        Ret = "'" & wbPath & "[" & MijnBestand & "]" & wsName & "'!" & Range(cellRef).Address(True, True, -4150)
        On Error Resume Next
        Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = ExecuteExcel4Macro(Ret)
        MijnBestand = Dir
    Loop

 

[Roncancio]

Sub Uitlezen()
Dim str() As String
Dim sPth As String
    sPth = "C:\test\"
    ReDim Preserve str(1, 0)
    d = Dir(sPth & "*.xl*")
    While d <> ""
        str(0, UBound(str, 2)) = ExecuteExcel4Macro("'" & sPth & "[" & d & "]Blad1'!R1C5")
        str(1, UBound(str, 2)) = ExecuteExcel4Macro("'" & sPth & "[" & d & "]Blad1'!R67C5")
        d = Dir
        ReDim Preserve str(1, UBound(str, 2) + 1)
    Wend
   Range("A1").Resize(UBound(str, 2), 2) = str
   Erase str
End Sub

Met vriendelijke groet,


Roncancio

 

[trebie]

Opgelost! Bedankt!

SjonR bedankt! Jouw oplossing werkt perfect! Heb de bestanden idd allemaal in 1 map staan en krijg nu netjes een nieuw bestand met de 2 kolommen gevuld.

Ook de anderen die gereageerd hebben bedankt voor jullie reacties! :thumb:

 

[Roncancio]

Graag nog bovenaan het scherm de vraag op opgelost zetten.
Bvd.

Met vriendelijke groet,


Roncancio

 

[snb]

Ik denk dat deze wel iets sneller loopt:

Sub M_snb()
    c00 = "G:\OF\"
    c01 = Dir(c00 & "*.xls")
    ReDim sn(800, 1)
    j = 0
    
    Do While c01 <> ""
      With GetObject(c00 & c01).Sheets(1)
         sn(j, 0) = .Cells(1, 5)
         sn(j, 1) = .Cells(67, 5)
         .Parent.Close 0
      End With
      j = j + 1
      c01 = Dir
    Loop
    
    ThisWorkbook.Sheets(1).Cells(1).Resize(UBound(sn) + 1, UBound(sn, 2) + 1) = sn
End Sub