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

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

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,294
Messages
5,571,383
Members
412,385
Latest member
OChambo94
Top