data uit ander workbook

[Interface]

Voor het samenvoegen van ong. 25 excel files heb ik nu de onderstaande code.

Echter is dit heel traag. Nu moeten hier toch beter manieren voor zijn zonder een andere workbook helemaal te moeten openen en te moeten sluiten? Ik heb al een manier gevonden om het met een sql command op te halen maar dan moet ik een DAO verwijzing toevoegen en dat doe ik liever niet.

Private Function funFolderPath() As String

        Dim strFile             As String
        Dim varFiles            As FileDialog
        Dim strPath             As String

        Set varFiles = Application.FileDialog(4)
    
        With varFiles
            .AllowMultiSelect = False
            .Title = "Selecteer de map met de Excel bestanden."
            If .Show = -1 Then strPath = .SelectedItems(1)
        End With
        If strPath = "" Then Exit Function
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        funFolderPath = strPath
End Function

 Sub Test() 
    
    Dim sq              As Variant
    Dim wb              As Workbook
    Dim objFolder       As Object
    Dim objItem         As Object
    
    Application.ScreenUpdating = False
    
    Set objFolder = CreateObject("Scripting.FileSystemObject").GetFolder(funFolderPath)

    For Each objItem In objFolder.Files
        Set wb = Workbooks.Open(objItem.path)
        With wb
            sq = wb.Sheets(1).UsedRange
            .Close
        End With
        Set wb = Nothing
        Sheets("1").Range("a" & Sheets("1").UsedRange.Rows.count + 1).Resize(UBound(sq), UBound(sq, 2)) = sq
    Next

    Application.ScreenUpdating = True

End Sub

 

[snb]

Sub M_snb()
  Application.ScreenUpdating = False
    
  With Application.FileDialog(4)
    If .Show Then c00 = .SelectedItems(1)
  End With
  If c00 = "" Then Exit Sub
    
  For Each it In CreateObject("Scripting.FileSystemObject").GetFolder(c00).Files
    With GetObject(it)
      sq = .Sheets(1).UsedRange
      .Close 0
    End With

    Sheet1.Cells(Rows.Count, 1).Offset(1).Resize(UBound(sq), UBound(sq, 2)) = sq
  Next

  Application.ScreenUpdating = True
End Sub

 

[Interface]

Thanx SNB!

 

[snb]

Ik weet niet hoe je werkboek eruit zien, wellicht helpt calculation=manual (ter voorkoming van herberekeningen) ook nog.