Small Help in Last row in Filtered Range

Haree

Board Regular
Joined
Sep 22, 2019
Messages
143
Office Version
  1. 2016
Hello All,
I am trying to sort out a code which auto filters data from various sheets and copies to a new sheet.
I have a problem in last row once the data is filtered. The last row brings out the actual last row value instead of visible cells ( For Example after auto filtering there are only 4 rows , but the last rows Excel serial number is 1109 , so last row is reflecting as 1109). Any help would be greatly appreciated. I just need to copy the filtered data. Thank you for your time.

I have attached the code below. I am unable to add a sample sheet through XL2BB add in as the data is sensitive. If it all you require a sample let me know, I will post sample values. Thanks once again

VBA Code:
Sub ledger()
Dim ws As Worksheet, wsd As Worksheet, lr As Long
Set wsd = Sheets("Cust.Ledger")
For Each ws In Worksheets

    Select Case ws.name
        Case "Rate Update", "Receivables", "Cust.Ledger", "Names"
        Case Else
        ws.AutoFilterMode = False
        ws.Range("A1:K1").AutoFilter Field:=3, Criteria1:=wsd.Range("K3").Value
        lr = ws.Range("A" & Rows.Count).End(xlUp).Row
            If lr > 1 Then
            ws.Range("A2:K" & lr).Copy wsd.Range("A2")
            Else
            End If
        ws.AutoFilterMode = False
    End Select
    Next
End Sub
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,539
Replace the If ... End If block with:
VBA Code:
        If ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            ws.AutoFilter.Range.SpecialCells(xlVisible).Copy wsd.Range("A2")
        End If
 
Solution

Haree

Board Regular
Joined
Sep 22, 2019
Messages
143
Office Version
  1. 2016
Hello @John_w It worked Perfectly Thank you so much for taking out time to help me. It would be very helpful if you could guide me in offsetting the copy part. The first row is header I don't want it to be copied.
I tried the following but it doesn't work properly

VBA Code:
ws.AutoFilter.Range.SpecialCells(xlVisible).offset(1,0).Copy wsd.Range("A2")

Thanks
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,539
The Offset(1,0) should copy from the first visible row below the header row. In what way doesn't it work?

Your code would give odd results if more than 1 sheet is filtered and copied, because it filters columns A:K using K3 in the "Cust.Ledger" sheet, which is overwritten by the first filtered results, and every copied results overwrites the previous results because it always copies to A2 on the "Cust.Ledger" sheet. Is that meant to happen?
 

Haree

Board Regular
Joined
Sep 22, 2019
Messages
143
Office Version
  1. 2016
Sir that was a silly mistake which I made. so have changed the destination. But the offset part still doesn't work, It copies a different section. Without the offset the copy works correctly. The updated code is as below

VBA Code:
Sub ledger()
Dim ws As Worksheet, wsd As Worksheet, lr As Long, lrd As Long
Set wsd = Sheets("Cust.Ledger")
For Each ws In Worksheets

    Select Case ws.name
        Case "Rate Update", "Receivables", "Cust.Ledger", "Names"
        Case Else
        ws.AutoFilterMode = False
        ws.Range("A1:K1").AutoFilter Field:=3, Criteria1:=wsd.Range("L3").Value
        lrd = wsd.Range("A" & Rows.Count).End(xlUp).Row
        lr = ws.Range("A" & Rows.Count).End(xlUp).Row
            If ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
            ws.AutoFilter.Range.SpecialCells(xlVisible).Offset(1, 0).Copy wsd.Range("A" & lrd + 1)
            End If
        ws.AutoFilterMode = False
    End Select
    Next
End Sub

Thanks for your time sir
 

Haree

Board Regular
Joined
Sep 22, 2019
Messages
143
Office Version
  1. 2016
It isnt offsetting the visible cells instead it offsets every cell of the visible cell so the data changes
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,539
Try this:
VBA Code:
Sub ledger()
    
    Dim ws As Worksheet, wsd As Worksheet, lrd As Long
    Dim copyRange As Range
    
    Set wsd = Sheets("Cust.Ledger")
    For Each ws In Worksheets
        Select Case ws.Name
            Case "Rate Update", "Receivables", "Cust.Ledger", "Names"
            Case Else
                With ws
                    If .FilterMode Then .AutoFilterMode = False
                    .Range("A1:K1").AutoFilter
                    With .AutoFilter.Range
                        .AutoFilter Field:=3, Criteria1:=wsd.Range("L3").Value
                        Set copyRange = Nothing
                        On Error Resume Next
                        Set copyRange = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                        If Not copyRange Is Nothing Then
                            lrd = wsd.Range("A" & Rows.Count).End(xlUp).Row + 1
                            copyRange.Copy wsd.Range("A" & lrd)
                        End If
                    End With
                    .AutoFilterMode = False
                End With
        End Select
    Next
    
End Sub
 

Haree

Board Regular
Joined
Sep 22, 2019
Messages
143
Office Version
  1. 2016
This worked perfectly sir. Thank you so much
 

Forum statistics

Threads
1,175,859
Messages
5,899,906
Members
434,805
Latest member
Nihon

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
Top