Help! want to make a compiler who transfer all data from all sheets to Sheet4

[Harpreet Singh]

Hi Experts,

i want to make a simple compiler to copy data from all the sheets to sheet4. i found an error in the following code.

Sub Complier()
Dim ws As Worksheet
Dim lst1 As Integer

For Each ws In ThisWorkbook.Worksheets

If ws.Name <> "Sheet4" Then
lst1 = ws.Range("A" & Rows.Count).End(xlUp).Row

ws.Range(Range("A2"), Range("" & lst1)).Copy Destination:=Sheet4.Range("A"& Rows.Count).End(xlUp).Offset(1,0)
End If

Next ws


End Sub

Please help in finding the error. sample workbook is attached.

 

[Luke M]

Two issues:

First, this line is definitely wrong:
ws.Range(Range("A2"), Range("" & lst1)).Copy Destination:=Sheet4.Range("A"& Rows.Count).End(xlUp).Offset(1,0)

You can give a range of a single number. This is the problem with bold part. Next, the two Range objects in red have not been given a parent object, so XL will assume they refer to the active sheet, not the ws object.

Line should be corrected to:

ws.Range("A2:A" & lst1).Copy Destination:=Sheet4.Range("A"& Rows.Count).End(xlUp).Offset(1,0)

The other issue, which may be a problem, is that you defined lst1 as an Integer, which can only have a max value of 32,767. Since worksheets can have more rows than that, you may get an error if the last row is beyond that limit. I would recommend defining lst1 as a Long, not an Integer.

 

[Harpreet Singh]

This is working fine, thanks.

i want a small amendment in my code
if sheet4 have duplicate records i want to generate a msgbox with vbYes vbNo
if yes then delete records else keep the records.

can you please help in this.

 

[Luke M]

How's this?

Sub Complier()
Dim ws As Worksheet
Dim lst1 As Long
Dim rngSource As Range
Dim rngUnique As Range


Application.ScreenUpdating = False
'Gather data
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Sheet4" Then
        lst1 = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        ws.Range("A2:A" & lst1).Copy Destination:=Sheet4.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
Next ws


'NOTE: Assumes that there is a header cell in A1
With Worksheets("Sheet4")
    'Test for duplicates
    Set rngSource = .Range("A1").CurrentRegion
  
    'Filter to unique
    rngSource.AdvancedFilter xlFilterCopy, , .Range("C1"), True
  
    Set rngUnique = .Range("C1").CurrentRegion
  
    'Compare source to Unique list
    If rngSource.Rows.Count <> rngUnique.Rows.Count Then
        If MsgBox("DUplicate entires found. Remove duplicates?", vbYesNo + vbDefaultButton2, "Duplicates") = vbYes Then
            'If yes, keep only uniques
            rngSource.Clear
            rngUnique.Cut .Range("A1")
        Else
            'Otherwise, clear unique list, keep original
            rngUnique.Clear
    Else
        'List was already unique
        rngUnique.Clear
    End If
End With
Application.ScreenUpdating = True

End Sub