Kopiering af værdier fra subtotaler

Via VBA skulle det være muligt at opbygge subtotalerne på ark2.

Du er velkommen til at sende en model m/såvel Ark1 & 2 - eller fuld kopi (mailadr. i profil)

Dim pNr
Dim ark1, formel, værdiF, værdiG, værdiH, værdiI, antalRækker1, antalRækker2
Dim ræk1, ræk2
Sub overførSubtotaler()
    Application.ScreenUpdating = False
   
Rem Find antal rækker på ark1
    ActiveWorkbook.Sheets("Ark1").Activate
    antalRækker1 = findAntalrækker
    Set ark1 = ActiveWorkbook.Sheets("Ark1")

Rem aktiver igen ark2
    ActiveWorkbook.Sheets("Ark2").Activate
    antalRækker2 = findAntalrækker
   
Rem Rem traverser ark2
    ræk2 = 2
   
    For ræk = ræk2 To antalRækker2
        If Cells(ræk, 1) <> "" Then
            pNr = Cells(ræk, 1)
           
            ræk1 = findPnrPåArk1(pNr)
            If ræk1 > 0 Then
                With ark1
                    værdiF = .Cells(ræk1, 6)
                    værdiG = .Cells(ræk1, 7)
                    værdiH = .Cells(ræk1, 8)
                    værdiI = .Cells(ræk1, 9)
                End With
               
                With ActiveSheet
                    .Cells(ræk, 4) = værdiF
                    .Cells(ræk, 5) = værdiG
                    .Cells(ræk, 6) = værdiH
                    .Cells(ræk, 7) = værdiI
                End With
            End If
        End If
    Next ræk
   
    Application.ScreenUpdating = False
   
    MsgBox ("Overførlsel af subtotaler afsluttet")
End Sub
Private Function findAntalrækker()
    findAntalrækker = ActiveCell.SpecialCells(xlLastCell).Row
End Function
Private Function findPnrPåArk1(pNr)
Dim subTotal
    subTotal = CStr(pNr) + " Total"                'Id af række med projektnr + teksten Subtotal
   
    With ark1.Range("B1:B" + CStr(antalRækker1))
        Set c = .Find(subTotal, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findPnrPåArk1 = c.Row
        Else
            findPnrPåArk1 = 0
        End If
    End With
End Function