Trying to Copy data from folder into 1 file as Sheet

Shazir

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows
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

VBA Code:
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
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Shazir

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows
Someone can please help me in this regard.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,311
Office Version
  1. 365
Platform
  1. Windows
Do you want to create a new sheet for the data?
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,311
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

Shazir

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows
Yes, It will be cleared the existing data from Sheet1.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,311
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Ok, how about
VBA Code:
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
 
Solution

Shazir

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows

Fluff,​

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

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,311
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback.
 

Shazir

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows

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 ?
 

Watch MrExcel Video

Forum statistics

Threads
1,123,346
Messages
5,601,080
Members
414,426
Latest member
fraru

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top