excel - 我该如何优化这个宏？

Question

我有一个按月和临时从 VBA 代码构建的投资组合报告。它今天运行良好，但底层 VBA 远未优化。下面的代码片段重复了 5 次，因为现在系统中有 5 个项目，但很快就会增长到 50 个。有没有人对我如何更优雅地利用 VBA 执行复制到代码中指定的位置有建议（见下面的片段）

Sub CreatePortFolio()

    Application.ScreenUpdating = False
        
    'Clears old data
    Application.Goto Reference:="PFData" 'Named range in the portfolio overview sheet
    Selection.ClearContents
        
'************* Project 1
    If Not Sheets(Sheets.Count).Range("BG1").Value = "" Then
        Ark4.Range("B5").Value = Sheets(Sheets.Count).Range("BG1").Value 'Ark4 is the portfolio report and the sheets.count is used to pick the latest import of data - always in the same format
        Ark4.Range("C5").Value = Sheets(Sheets.Count).Range("BF1").Value
        Ark4.Range("D5").Value = Sheets(Sheets.Count).Range("BH1").Value
        Ark4.Range("E5").Value = Sheets(Sheets.Count).Range("AU1").Value
        Ark4.Range("F5").Value = Sheets(Sheets.Count).Range("AU2").Value
        Ark4.Range("G5").Value = Sheets(Sheets.Count).Range("AU3").Value
        Ark4.Range("H5").Value = Sheets(Sheets.Count).Range("AV1").Value
        Ark4.Range("I5").Value = Sheets(Sheets.Count).Range("AV2").Value
        Ark4.Range("J5").Value = Sheets(Sheets.Count).Range("AV3").Value

        Ark4.Range("L4").Value = Sheets(Sheets.Count).Range("AP3").Value
        Ark4.Range("L5").Value = Sheets(Sheets.Count).Range("AP4").Value
        Ark4.Range("L6").Value = Sheets(Sheets.Count).Range("AP5").Value
        Ark4.Range("M4").Value = Sheets(Sheets.Count).Range("AQ3").Value
        Ark4.Range("M5").Value = Sheets(Sheets.Count).Range("AQ4").Value
        Ark4.Range("M6").Value = Sheets(Sheets.Count).Range("AQ5").Value
        Ark4.Range("N4").Value = Sheets(Sheets.Count).Range("AR3").Value
        Ark4.Range("N5").Value = Sheets(Sheets.Count).Range("AR4").Value
        Ark4.Range("N6").Value = Sheets(Sheets.Count).Range("AR5").Value
        Ark4.Range("O4").Value = Sheets(Sheets.Count).Range("AS3").Value
        Ark4.Range("O5").Value = Sheets(Sheets.Count).Range("AS4").Value
        Ark4.Range("O6").Value = Sheets(Sheets.Count).Range("AS5").Value

        Ark4.Range("Q4").Value = Sheets(Sheets.Count).Range("AP10").Value
        Ark4.Range("Q5").Value = Sheets(Sheets.Count).Range("AP11").Value
        Ark4.Range("Q6").Value = Sheets(Sheets.Count).Range("AP12").Value
        Ark4.Range("R4").Value = Sheets(Sheets.Count).Range("AQ10").Value
        Ark4.Range("R5").Value = Sheets(Sheets.Count).Range("AQ11").Value
        Ark4.Range("R6").Value = Sheets(Sheets.Count).Range("AQ12").Value
        Ark4.Range("S4").Value = Sheets(Sheets.Count).Range("AR10").Value
        Ark4.Range("S5").Value = Sheets(Sheets.Count).Range("AR11").Value
        Ark4.Range("S6").Value = Sheets(Sheets.Count).Range("AR12").Value
        Ark4.Range("T4").Value = Sheets(Sheets.Count).Range("AS10").Value
        Ark4.Range("T5").Value = Sheets(Sheets.Count).Range("AS11").Value
        Ark4.Range("T6").Value = Sheets(Sheets.Count).Range("AS12").Value

        Ark4.Range("U5").Value = Sheets(Sheets.Count).Range("AW4").Value
        Ark4.Range("V5").Value = Sheets(Sheets.Count).Range("AW3").Value
    End If
    
  
    '******* I Want to avoid copying the above code 50 times *******
       
    Application.ScreenUpdating = True
        
End Sub

投资组合报告如下所示：

用于构建报告的数据表如下所示：

标签： excelvba

Answer 1

尝试，

Sub test()
    Dim wsData As Worksheet
    Dim Ws As Worksheet
    Dim vDB As Variant
    Dim vR() As Variant
    Dim Ark4 As Worksheet
    Dim i As Long, n As Long, r As Long
    
    
    
    Set Ark4 = Sheets(1) ' set your sheets
    Set wsData = Sheets(Sheets.Count)
    
    With wsData
        r = .Range("BG" & Rows.Count).End(xlUp).Row + 11
        vDB = .Range("ap1", "bh" & r)
    End With
    For i = 1 To r Step 12
        If vDB(i, 18) <> "" Then
            n = n + 3
            ReDim Preserve vR(1 To 21, 1 To n)
            
            'Column b ~ j
            vR(1, n - 2) = vDB(i, 18) 'bg1
            vR(2, n - 2) = vDB(i, 17) 'bf1
            vR(3, n - 2) = vDB(i, 19)
            vR(4, n - 2) = vDB(i, 6)
            vR(5, n - 2) = vDB(i + 1, 6)
            vR(6, n - 2) = vDB(i + 2, 6)
            vR(7, n - 2) = vDB(i, 7)
            vR(8, n - 2) = vDB(i + 1, 7)
            vR(9, n - 2) = vDB(i + 2, 7)
            
            'Column k ~ o
            vR(10, n - 2) = "Budget"
            vR(10, n - 1) = "Installemnt"
            vR(10, n) = "Deviation"
            
            vR(11, n - 2) = vDB(i + 2, 1) 'ap3
            vR(11, n - 1) = vDB(i + 3, 1) 'ap4
            vR(11, n) = vDB(i + 4, 1)     'ap5
            vR(12, n - 2) = vDB(i + 2, 2) 'aq3
            vR(12, n - 1) = vDB(i + 3, 2) 'aq4
            vR(12, n) = vDB(i + 4, 2)     'aq5
            vR(13, n - 2) = vDB(i + 2, 3) 'ar3
            vR(13, n - 1) = vDB(i + 3, 3) 'ar4
            vR(13, n) = vDB(i + 4, 3)     'ar5
            vR(14, n - 2) = vDB(i + 2, 4) 'as3
            vR(14, n - 1) = vDB(i + 3, 4) 'as4
            vR(14, n) = vDB(i + 4, 4)     'as5
            
            'Column p ~ z
            vR(15, n - 2) = "Budget"
            vR(15, n - 1) = "Installemnt"
            vR(15, n) = "Deviation"
    
            vR(16, n - 2) = vDB(i + 9, 1) 'ap10
            vR(16, n - 1) = vDB(i + 10, 1) 'ap11
            vR(16, n) = vDB(i + 11, 1)     'ap12
            vR(17, n - 2) = vDB(i + 9, 2) 'aq10
            vR(17, n - 1) = vDB(i + 10, 2) 'aq11
            vR(17, n) = vDB(i + 11, 2)     'aq12
            vR(18, n - 2) = vDB(i + 9, 3) 'ar10
            vR(18, n - 1) = vDB(i + 10, 3) 'ar11
            vR(18, n) = vDB(i + 11, 3)     'ar12
            vR(19, n - 2) = vDB(i + 9, 4) 'as10
            vR(19, n - 1) = vDB(i + 10, 4) 'as11
            vR(19, n) = vDB(i + 11, 4)     'as12
            
            'Column u,v
            vR(20, n - 2) = vDB(i + 3, 8) 'aw4
            vR(21, n - 2) = vDB(i + 2, 8) 'aw3
        End If
    Next i
    
    With Ark4
        .Range("b4").Resize(n, 21) = WorksheetFunction.Transpose(vR)
    End With
End Sub

假设数据表中的数据重复如下图所示。