Trying to Copy data from folder into 1 file as Sheet

[Shazir]

Hi, I hope everything is going well.

I have been finding a code which open the pop up window to select the folder where multiple files are placed.

Then code will select the folder and copy the data from all sheets (whatever the sheet name is) into the sheet where from code is being run and it should be paste as values.

all files header should be deleted except 1st file so headers could not be repeated multiple times according number of files.

Looking for positive response Thanks

Sub copydata()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[Shazir]

Someone can please help me in this regard.

 

[Fluff]

Do you want to create a new sheet for the data?

 

[Shazir]

Fluff,​

No, It should be Sheet1.

 

[Fluff]

In that case does sheet1 need to be cleared before copying, or will it already be empty?

 

[Shazir]

Yes, It will be cleared the existing data from Sheet1.

 

[Fluff]

Ok, how about

Sub Shazir()
   Dim Fldr As String, Fname As String
   Dim wsDest As Worksheet, Ws As Worksheet
   Dim Flg As Boolean
   
   Application.ScreenUpdating = False
   Set wsDest = ThisWorkbook.Sheets("Sheet1")
   wsDest.UsedRange.Clear
   With Application.FileDialog(4)
      .AllowMultiSelect = False
      If .Show Then Fldr = .SelectedItems(1) & "\"
   End With
   Fname = Dir(Fldr & "*.xls*")
   Do While Fname <> ""
      With Workbooks.Open(Fldr & Fname)
         For Each Ws In .Worksheets
            Ws.UsedRange.Offset(-Flg).Copy wsDest.Range("A" & Rows.Count).End(xlUp).Offset(1)
            Flg = True
         Next Ws
         .Close False
      End With
      Fname = Dir
   Loop
End Sub

 

[Shazir]

Fluff,​

Sir Thank you so much for the help. Thanks again.

 

[Fluff]

You're welcome & thanks for the feedback.

 

[Shazir]

Fluff​

Sir, if its possible than please edit the code bit.

that i want to paste the same data in Sheet2 as well.

When i run the code data should be paste in two files Sheet1 and Sheet2.

Is it possible ?