vba code to copy charges code,their respective cells and sum their amount

I Have a workbook workings sheet

Need to copy a list of charges code at end of column F, G with charges value at end columns AA copy it to column AL to AM , autosum AM COLUMNS

the charges codes can be 3,4 ,5, 6 depending of po orders (on sheet only 2 shown as example)

however the code always start with F with a space before F

AND delete their respective positions

the workings sheet is dynamic as it may contains 100 to to 10000 rows of data

Dear Jean,

If the rows with charging codes are always at the end of the list, and the first row of Charging codes has an empty cell in column E, the following code wil work.

Sub Macro1()
'
' copy+paste charging codes + autosum
'
Dim intLastRow As Integer
Dim intFirstRow As Integer


    Range("E1").End(xlDown).Select
    intFirstRow = Selection.Row + 1
    
    Range("F" & intFirstRow).Select
    Range(Selection, Selection.End(xlDown)).Select
    intLastRow = intFirstRow + Selection.Rows.Count - 1
    
    Range("F" & intFirstRow & ":G" & intLastRow).Copy
    Range("AL2").Select
    ActiveSheet.Paste
        
    Range("AA" & intFirstRow & ":AA" & intLastRow).Copy
    Range("AN2").Select
    ActiveSheet.Paste
    
    Range(intFirstRow & ":" & intLastRow).Delete
    
    Range("AN2").End(xlDown).Select
    intLastRow = Selection.Row
    
    Range("AN" & intLastRow + 1).Select
    ActiveCell.FormulaR1C1 = "=SUM(R[-" & intLastRow - 1 & "]C:R[-1]C)"
    
    Columns("AL:AN").EntireColumn.AutoFit
    Range("AN" & intLastRow + 1).Select
End Sub

Succes and let me know if this helps.

Ton

Try

Sub test()
    Dim a, i As Long, x As Range, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    a = Sheets("expected coding charges code").Cells(1).CurrentRegion.Value
    For i = 1 To UBound(a, 1)
        dic(a(i, 1) & ";" & a(i, 2)) = Empty
    Next
    With Sheets("workings")
        .Range("al2").CurrentRegion.Clear
        For i = .Range("f" & Rows.Count).End(xlUp).Row To 1 Step -1
            If dic.exists(.Cells(i, "f").Value & ";" & .Cells(i, "g").Value) Then
                If x Is Nothing Then
                    Set x = Union(.Range("f" & i).Resize(, 2), .Range("aa" & i))
                Else
                    Set x = Union(x, Union(.Range("f" & i).Resize(, 2), .Range("aa" & i)))
                End If
            Else
                Exit For
            End If
        Next
        If Not x Is Nothing Then
            x.Copy .Range("al2")
            .Range("an1").Value = "Amount"
            .Range("an" & Rows.Count).End(xlUp)(2).FormulaR1C1 = "=sum(r2c:r[-1]c)"
            .Range("al2").CurrentRegion.Borders.Weight = 2
            x.EntireRow.Clear
        End If
    End With
End Sub

Ton and Jindon

Thank you

Hi Jindon

I noticed that the code looks a = Sheets("expected coding charges code").Cells(1).CurrentRegion.Value
But what I was looking for that the code look directly in the sheet workings column F and G.

the expected coding charges was a dummy of what charges may have.

So could you adjust the code

thnak you

F_DO	FRAIS DOUANE
F_PAL	PALETTES 80X120 LOURDE  NIMP15

Is this how you wanted?
Find blank(s) in the bottom col.E within the data range.

Sub test()
    Dim x As Range
    With Sheets("workings")
        .Range("al2").CurrentRegion.Clear
        On Error Resume Next
        Set x = .Range("a1").CurrentRegion.Columns("e").SpecialCells(4)
        On Error GoTo 0
        If Not x Is Nothing Then
            With x.EntireRow
                Set x = Union(.Columns("f:g"), .Columns("aa"))
            End With
            x.Copy .Range("al2")
            .Range("an1").Value = "Amount"
            .Range("an" & Rows.Count).End(xlUp)(2).FormulaR1C1 = "=sum(r2c:r[-1]c)"
            .Range("al2").CurrentRegion.Borders.Weight = 2
            x.EntireRow.Clear
        End If
    End With
End Sub