VBA Code Problem

Shazir

Banned - Rules violations
Joined
Jul 28, 2020
Messages
94
Office Version
  1. 365
Platform
  1. Windows
I have been using this code and while applying it on a folder if there are 5 or more workbooks in a folder then it would create a Sheet with NewSheet and where it paste the used range twice.

For example Workbook.Sheet1 has data till 200 rows it will paste it till 400 that is 200+200.

I don't know why it is happening

If i apply 2nd code on single sheet it works perfectly


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 = "NewSheet"
Set ms = Sheets("NewSheet")
For Each sht In wbk.Sheets
If sht.Name <> "New 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



Sub CombineData()
Dim I As Long
Dim xRg As Range
On Error Resume Next
Worksheets.Add Sheets(1)
ActiveSheet.Name = "NewSheet"

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
 

Some videos you may like

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,718
Office Version
  1. 2013
Platform
  1. Windows
The main thing I saw was a typo in the new sheet name.(see red font) It had a space between New and Sheet.

Rich (BB 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 = "NewSheet"
     Set ms = Sheets("NewSheet")
     For Each sht In wbk.Sheets
        If sht.Name <> "NewSheet" 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 so much
 

Watch MrExcel Video

Forum statistics

Threads
1,118,607
Messages
5,573,193
Members
412,513
Latest member
PayneEdward
Top