VBA: Import every new data into a new column

[Ouble]

Hi all, in need of some help to import new data into new column. Currently, Ive only managed to import the data but with every new data, they are stacked below. I need them to be in a new column. Eg. data1 A2:B2, data2 D2:E2, etc...

Also, is it possible to import the filename of the import data at the row before the data? Eg. A1, D1, etc...

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.Range("A" & wsDst.Rows.Count).End(xlUp).Offset(2)
        ActiveSheet.UsedRange.Resize(, 2).Copy rngDst
        FN = Dir()
        ActiveWorkbook.Close False
    Loop
End Sub

Ouble

 

[JLGWhiz]

see if this works for you

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(1, Columns.Count).End(xlToLeft).Offset(0, 2)
        ActiveSheet.UsedRange.Resize(, 2).Copy rngDst
        wsDst.Cells(1, Colums.Count).End(xlToLeft).Offset(0, -1).Insert xlShiftDown
        wsDst.Cells(1, Colums.Count).End(xlToLeft).Offset(0, -1) = FN
        FN = Dir()
        ActiveWorkbook.Close False
    Loop
End Sub

 

[Ouble]

Thank JLGWhiz, there seemed to be a runtime error 'object required' on
wsDst.Cells(1, Colums.Count).End(xlToLeft).Offset(0, -1).Insert xlShiftDown
wsDst.Cells(1, Colums.Count).End(xlToLeft).Offset(0, -1) = FN

any idea how? Thanks

Ouble

 

[JLGWhiz]

Thank JLGWhiz, there seemed to be a runtime error 'object required' on
wsDst.Cells(1, Colums.Count).End(xlToLeft).Offset(0, -1).Insert xlShiftDown
wsDst.Cells(1, Colums.Count).End(xlToLeft).Offset(0, -1) = FN

any idea how? Thanks

Ouble

Columns is misspelled. Insert the 'n' in both places and it should work OK.

 

[Ouble]

Thanks thanks!

Ive edited it to suit my format. Thanks for the help.

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

 

[JLGWhiz]

Thanks thanks!

Ive edited it to suit my format. Thanks for the help.



Ouble

Thanks fror the feed back,
Regards, JLG