Do while Loop Correction

[Shazir]

Trying to modify the code I want to apply this code on all workbooks in a folder but do not know how to do this please look into this.

Sub Copydata()
Dim xFd As FileDialog
    Dim xFdItem As String
    Dim xFileName As String
    Dim wbk As Workbook
    Dim sht As Worksheet
  
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
    Else
        Beep
        Exit Sub
    End If
xFileName = Dir(xFdItem & "*.xlsx")
Do While xFileName <> ""

  Set wbk = Workbooks.Open(xFdItem & xFileName)



  For Each sht In wbk.Sheets
sht.Add Sheets(1)
ActiveSheet.Name = "MasterSheet"

For I = 2 To Sheets.Count
Set xRg = Sheets(1).UsedRange

If I > 2 Then
Set xRg = Sheets(1).Cells(xRg.Rows.Count + 1, 1)
End If
Sheets(I).Activate
ActiveSheet.UsedRange.Copy xRg
Next

  Next

  wbk.Close SaveChanges:=True

  xFileName = Dir
Loop
End Sub

 

[mrshl9898]

Is this what you wanted?

Sub Copydata()

Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet
Dim Last_Row As Long

Set xFd = Application.FileDialog(msoFileDialogFolderPicker)

If xFd.Show Then
    xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
Else
    Beep
    Exit Sub
End If

xFileName = Dir(xFdItem & "*.xlsx")

Do While xFileName <> ""
Set wbk = Workbooks.Open(xFdItem & xFileName)
Sheets.Add.Name = "MasterSheet"
Set ms = Sheets("MasterSheet")
    For Each sht In wbk.Sheets
            If sht.Name <> "Master Sheet" Then
                ms.UsedRange
                Last_Row = ms.UsedRange.Rows(ms.UsedRange.Rows.Count).Row
                sht.UsedRange.Copy ms.Range("A" & Last_Row + 1)
            End If
    Next sht
wbk.Close SaveChanges:=True
xFileName = Dir
Loop

End Sub

 

[Shazir]

Thank you its working like rocket.