copy lastrow for each name in range from sheet to another

[Abdo]

Hi
I want showing the lastrow for each name from sheet to another based on column C in sheet filter with ignore columns A,B,D
sheet filter

f .xlsm
	A	B	C	D	E	F	G
1	DATE	INVOICE NO	CLIENT NO	DESCRIBE	DEBIT	CREDIT	BALANCE
2	1/1/2022	-	ABDEND1	OPENNING	20,000.00	-	20,000.00
3	1/4/2022	PA-B3	ABDEND1	PA	20,000.00	-	40,000.00
4	1/5/2022	SA-B35	ABDEND1	SA	-	1,000.00	39,000.00
5	1/2/2022	PA-B36	ABDEND2	PA	1,000.00	-	1,000.00
6	1/7/2022	PA-B37	ABDEND2	PA	1,000.00	-	2,000.00
7	1/13/2022	PA-B45	ABDEND2	PA	1,000.00	100.00	2,900.00
8	1/3/2022	PA-B38	ABDEND3	openning	-	200.00	-200.00
9	1/6/2022	PA-B39	ABDEND3	PA	5,000.00	-	4,800.00
10	1/8/2022	PA-B40	ABDEND3	PA	5,000.00	-	9,800.00
11	1/9/2022	PA-B41	ABDEND3	PA	5,000.00	-	14,800.00
12	1/10/2022	PA-B42	ABDEND3	PA	2,000.00	-	16,800.00
13	1/11/2022	PA-B43	ABDEND3	PA	1,000.00	100.00	17,700.00
14	1/12/2022	PA-B44	ABDEND4	PA	1,000.00	100.00	900.00
filter

the result in sheet OUTPUT from row2 with the same borders & formatting . with considering any changing or adding new data in sheet filter should update in sheet output .

f.xlsm
	A	B	C	D	E
1	ITEM	CLIENT NO	DEBIT	CREDIT	BALANCE
2	1	ABDEND1	-	1,000.00	39,000.00
3	2	ABDEND2	1,000.00	100.00	2,900.00
4	3	ABDEND3	1,000.00	100.00	17,700.00
5	4	ABDEND4	1,000.00	100.00	900.00
output

thanks

 

[jalrs]

See if this works for you:

Option Explicit
Sub abdo()

Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr As Long

Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("filter")
Set ws2 = wb.Worksheets("output")

lr = ws1.Cells(Rows.Count, "C").End(xlUp).Row

    With ws1
    
        .Range("C2:C" & lr).Copy
        ws2.Cells(2, 2).PasteSpecial Paste:=xlPasteFormats
        ws2.Cells(2, 2).PasteSpecial Paste:=xlPasteValues
        
        .Range("E2:G" & lr).Copy
        ws2.Cells(2, 3).PasteSpecial Paste:=xlPasteFormats
        ws2.Cells(2, 3).PasteSpecial Paste:=xlPasteValues
        
    End With
             
End Sub

 

[jalrs]

Since I misinterpreted what you asked, I assume a new helper column on column H, with the unique values for Client No.
Someone else could provide a faster way of doing this.

I am sorry for thinking I could help you out, but as I said, I misinterpreted what you asked.

See if this works for you

Option Explicit
Sub abdo()

Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 as long, i As Long
Dim filtervalue As String

Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("filter")
Set ws2 = wb.Worksheets("output")

filtervalue = ws1.Cells(i, 8)

lr1 = ws1.Cells(Rows.Count, "C").End(xlUp).Row
lr2 = ws2.Cells(Rows.Count, "B").End(xlUp).Row + 1
lr3 = ws2.cells(Rows.Count, "C").End(xlup).Row +1

For i = 2 To lr1

    With ws1
       
        .AutoFilter 3, filtervalue
   
        .Range("C2:C" & lr1 -1).Copy
        ws2.Cells(lr2, 2).PasteSpecial Paste:=xlPasteFormats
        ws2.Cells(lr2, 2).PasteSpecial Paste:=xlPasteValues
       
        .Range("E2:G" & lr1 - 1).Copy
        ws2.Cells(lr3, 3).PasteSpecial Paste:=xlPasteFormats
        ws2.Cells(lr3, 3).PasteSpecial Paste:=xlPasteValues
       
    End With
   
        .AutoFilter
       
Next i
            
End Sub

 

[jalrs]

I believe this is what you want.
I assume you create a new sheet named "names" with unique values from column C, starting on row 2.

Option Explicit
Sub abdo()

Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lr1 As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, i As Long
Dim filtervalue As String, rngCC As String, rngEG As String

    With ThisWorkbook
    
        Set ws1 = .Worksheets("filter")
        Set ws2 = .Worksheets("output")
        Set ws3 = .Worksheets("names")
        
    End With
    
lr1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
lr2 = ws3.Cells(Rows.Count, "A").End(xlUp).Row

For i = 2 To lr2

    filtervalue = ws3.Cells(i, 1).Value
    
    With ws2
        
        lr3 = ws2.Cells(Rows.Count, "B").End(xlUp).Row + 1
        lr4 = ws2.Cells(Rows.Count, "C").End(xlUp).Row + 1
        
    End With
    
    With ws1.Range("A1:G" & lr1)
    
        .AutoFilter 3, filtervalue
        
        lr5 = ws1.Cells(Rows.Count, "C").End(xlUp).Row
        
        rngCC = "C" & lr5 & ":C" & lr5
        
        lr6 = ws1.Cells(Rows.Count, "E").End(xlUp).Row
        
        rngEG = "E2" & lr5 & ":G" & lr5
        
        With ws1
        
            .Range(rngCC).Copy
            ws2.Cells(lr3, 2).PasteSpecial Paste:=xlPasteValues
            
            .Range(rngEG).Copy
            ws2.Cells(lr4, 3).PasteSpecial Paste:=xlPasteValues
        
        End With
        
        .AutoFilter
        Application.CutCopyMode = False
        
    End With
    
    ws3.Activate
    
Next i

End Sub

 

[Abdo]

thanks based on last the code doesn't show any thing

 

[EXCEL MAX]

You can try this one.

Sub CreateReportUniqueLastRow()

   Dim vWS1 As Worksheet, vWS2 As Worksheet
   Dim vLastRow As String, vRng, vA1, vN As Long, vN2 As Long
   Dim vUnique As String, vAUnique

   Application.ScreenUpdating = False
   MsgBox "Wait to reach end"
   Set vWS1 = Sheets("filter")
   Set vWS2 = Sheets("output")
   vLastRow = vWS1.Cells(Rows.Count, "C").End(xlUp).Address
   Set vRng = vWS1.Range("A2", vWS1.Range(vLastRow).Offset(, 4))
   vA = vRng.Columns(3).Value
   For vN = 1 To UBound(vA)
      If InStr(1, vUnique, vA(vN, 1)) Then
      Else
         vUnique = vUnique & " §§§ " & vA(vN, 1)
      End If
   Next vN
   vAUnique = Split(vUnique, " §§§ ")
   vWS1.Cells(1, 1).Resize(, 7).Copy vWS2.Cells(1, 1).Resize(, 7)
   For vN2 = 1 To UBound(vAUnique)
      vFind = vRng.Columns(3).Find(vAUnique(vN2), , , xlWhole, , xlPrevious, True).Row
      vWS1.Cells(vFind, 1).Resize(, 7).Copy vWS2.Cells(vN2 + 1, 1).Resize(, 7)
   Next vN2
   MsgBox "End"
   Application.ScreenUpdating = True

End Sub

 

[Abdo]

@EXCEL MAX awesome your code !! , but I need somethings need fix ,please .
as I said in OP

with ignore columns A,B,D
sheet filter

I don't need theses columns
and based on the result in sheet output as is in OP should cancel date in column A and replace of it by numbers sequences 1,2,3....
last things I don't need the message box when run the macro it takes time to see the result .

 

[EXCEL MAX]

Sorry, I was hurry. Maybe now is little bit better.

Sub CreateReportUniqueLastRow()

   Dim vWS1 As Worksheet, vWS2 As Worksheet
   Dim vLastRow As String, vUnique As String
   Dim vRng As Range, vRng1 As Range, vRng2 As Range
   Dim vN As Long, vN2 As Long
   Dim vAUnique As Variant, vA As Variant

   Application.ScreenUpdating = False
   Set vWS1 = Sheets("filter")
   Set vWS2 = Sheets("output")
   vLastRow = vWS1.Cells(Rows.Count, "C").End(xlUp).Address
   Set vRng = vWS1.Range("A2", vWS1.Range(vLastRow).Offset(, 4))
   vA = vRng.Columns(3).Value
   For vN = 1 To UBound(vA)
      If InStr(1, vUnique, vA(vN, 1)) Then
      Else
         vUnique = vUnique & " §§§ " & vA(vN, 1)
      End If
   Next vN
   vAUnique = Split(vUnique, " §§§ ")
   Set vRng1 = Union(vWS1.Cells(1, 1), vWS1.Cells(1, 3), _
    vWS1.Cells(1, 5).Resize(, 3))
   vRng1.Copy vWS2.Cells(1, 1).Resize(, 5)
   For vN2 = 1 To UBound(vAUnique)
      vFind = vRng.Columns(3).Find( _
        vAUnique(vN2), , , xlWhole, , xlPrevious, True).Row
      Set vRng2 = Union(vWS1.Cells(vFind, 1), vWS1.Cells(vFind, 3), _
        vWS1.Cells(vFind, 5).Resize(, 3))
      vRng2.Copy vWS2.Cells(vN2 + 1, 1).Resize(, 5)
      vWS2.Cells(vN2 + 1, 1) = vN2
      vWS2.Cells(vN2 + 1, 1).NumberFormat = "0"
      vWS2.Cells(vN2 + 1, 3).Resize(, 3).NumberFormat = "0.00"
   Next vN2
   vWS2.Columns("A:E").AutoFit
   vWS2.Columns("B").ColumnWidth = vWS1.Columns("C").ColumnWidth
   Application.ScreenUpdating = True

End Sub

 

[Abdo]

@EXCEL MAX great !
but why the code is not fast . gives 0.11 the data are not big
I expect the running speed should be 0.02 0r 0.01

 

[EXCEL MAX]

Thanks for feedback.