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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
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
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top