Do While Loop Data to be Copied

[Shazir]

Using below code which is giving accurate and false result.

The problem is that when i apply the CombineData code for single file it works perfectly and makes MasterSheet as first sheet which comes before each sheet on the left hand side.

When i use Do While Loop code for some files by selecting a folder some files give accurate result and some give wrong that means MasterSheet is create at the end of the sheets and if the file has 10 sheets it will paste 10 sheets data twice. I do not know what is wrong with the code.

Looking for a solution.


Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.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
End Sub

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

 

[GWteB]

Not sure about the result but try ...

Sub Copydata()

Dim xFd As FileDialog
Dim xFdItem As String
Dim xFileName As String
Dim wbk As Workbook
Dim sht As Worksheet, ms 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)
    Set ms = wbk.Sheets.Add(Before:=wbk.Sheets(1))
    ms.Name = "MasterSheet"
        For Each sht In wbk.Sheets
            If sht.Name <> ms.Name Then
                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