VBA: Import every 5 .xls data into a new worksheet

[Ouble]

Hi all, Ive got the coding more or less down. However, im trying to figure out if excel could import the 1st 5 excel file's data to one Sheet 1 then the next 5 to Sheet 2, etc...

Currently, its importing everything into one sheet.

Any help is greatly appreciated. Thanks!

Sub ImportFiles()


    Dim Fldr As String, FN As String
    Dim wsDst As Worksheet, rngDst As Range
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        Fldr = .SelectedItems(1)
    End With
    
    Set wsDst = ThisWorkbook.Sheets("Sheet1")
    FN = Dir(Fldr & "\*.xls", vbNormal)
    
    Do While FN <> ""
        Workbooks.OpenText Filename:=Fldr & "\" & FN, Space:=False
        Set rngDst = wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(0, 2)
        ActiveSheet.UsedRange.Resize(, 2).Copy rngDst
        wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(0, -2).Insert xlShiftDown
        wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(-1, -1) = FN
        
        FN = Dir()
        ActiveWorkbook.Close False
    
    Loop
End Sub

Ouble

 

[JoeMo]

I haven't looked carefully at all your code so this may need a tweak. I assumed the sheet names are Sheet1, Sheet2, ..., and that the sheets needed are already in place and ready to accept the output of the macro.

    Dim Fldr As String, FN As String
    Dim wsDst As Worksheet, rngDst As Range
    Dim ct As Long, N As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        Fldr = .SelectedItems(1)
    End With
    
    FN = Dir(Fldr & "\*.xls", vbNormal)
    N = 1
    Do While FN <> ""
        ct = ct + 1
        If ct Mod 6 = 0 Then N = N + 1
        Set wsDst = ThisWorkbook.Sheets("Sheet" & N)
        Workbooks.OpenText Filename:=Fldr & "\" & FN, Space:=False
        Set rngDst = wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(0, 2)
        ActiveSheet.UsedRange.Resize(, 2).Copy rngDst
        wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(0, -2).Insert xlShiftDown
        wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(-1, -1) = FN
        
        FN = Dir()
        ActiveWorkbook.Close False
    
    Loop
End Sub

 

[Ouble]

Hi Joe,

Currently, sheet 1 is showing 5 results. The following sheet, sheet 2, sheet 3, etc... its importing 6 results.

Therefore, Im trying to play around with the code below but with no luck. What should I do?
ct = ct + 1
If ct Mod 6 = 0

Ouble

 

[JoeMo]

Hi Joe,

Currently, sheet 1 is showing 5 results. The following sheet, sheet 2, sheet 3, etc... its importing 6 results.

Therefore, Im trying to play around with the code below but with no luck. What should I do?
ct = ct + 1
If ct Mod 6 = 0

Ouble

Here's a revision.

Sub ImportFiles()
Dim Fldr As String, FN As String
    Dim wsDst As Worksheet, rngDst As Range
    Dim ct As Long, N As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then
            Exit Sub
        End If
        Fldr = .SelectedItems(1)
    End With
    
    FN = Dir(Fldr & "\*.xls", vbNormal)
    N = 1
    Do While FN <> ""
        ct = ct + 1
        Set wsDst = ThisWorkbook.Sheets("Sheet" & N)
        Workbooks.OpenText Filename:=Fldr & "\" & FN, Space:=False
        Set rngDst = wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(0, 2)
        ActiveSheet.UsedRange.Resize(, 2).Copy rngDst
        wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(0, -2).Insert xlShiftDown
        wsDst.Cells(2, Columns.Count).End(xlToLeft).Offset(-1, -1) = FN
        If ct Mod 5 = 0 Then N = N + 1
        FN = Dir()
        ActiveWorkbook.Close False
    
    Loop
End Sub

 

[Ouble]

Hi Joe,

Thanks! it works greatly!

Ouble