Do while Loop Correction

Shazir

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

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

Some videos you may like

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

mrshl9898

Well-known Member
Joined
Feb 6, 2012
Messages
1,549
Is this what you wanted?

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

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows
Thank you its working like rocket.
 

Watch MrExcel Video

Forum statistics

Threads
1,118,794
Messages
5,574,338
Members
412,587
Latest member
Krucial155
Top