excel - 修改当前代码循环到下一行

Question

我正在尝试创建一个宏，它将第一行 A8:V8 从 [Summary] 选项卡复制到 [Annual Statement] 选项卡，重新计算，然后将 [Annual Statement] 选项卡保存为 pdf，其中单元格 A8 的名称来自 [摘要] 选项卡。此代码按原样用于第一行 A8:V8。我想让这个宏更加动态并循环到下一行，A9:V9，然后重复将值复制到 [Annual Statement] 选项卡并保存为 pdf 的相同过程，然后再次重复整个过程下一行。

这是代码-</p>

Sub AnnualStatements()

Dim RI As Workbook
Set RI = ThisWorkbook

Dim strpath As String
Dim strName As String
Dim strFile As String
Dim strPathFile As String


**'Copies over policy information from summary to annual statement tab**

Worksheets("Summary").Range("A8:V8").Copy Worksheets("Annual Statement").Range("O3")

Calculate

**'Below is what I want to change the above line to but it isn't working**

For i = 1 to 10

Worksheets("Summary").Range(Cells(7+i, 1), Cells(7+i, 21)).Copy Worksheets("Annual Statement").Range("O3")

Calculate

**Creates location and path to save annual statement pdf file to**
strpath = "C:Users\Documents"
strName = Sheets("Summary").Range("A8")

**‘strName = Sheets(“Summary”).Cells(7+i,1)**  '' tried changing to this but not working

strFile = strName & "_Annual Statement" & ".pdf"
strPathFile = strpath & strFile

**Saves as pdf**

Worksheets("Annual Statement").ExportAsFixedFormat _
        Type:=xlTypePDF, _
        FileName:=strPathFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

**'Next i 'tried adding this but not working** 

End Sub

标签： excelvba

Answer 1

将工作表的版本导出为 PDF

Option Explicit

Sub ExportAnnualStatements()

    Const sName As String = "Summary"
    Const sFirst As String = "A8:V8"
    Const sPDFLeftColumn As Long = 1
    
    Const dFolderPath As String = "C:\Users\Documents\"
    Const dName As String = "Annual Statement"
    Const dFirst As String = "O3"

    If sPDFLeftColumn < 1 Then Exit Sub ' not gt 0
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = RefColumns(sws.Range(sFirst))
    If srg Is Nothing Then Exit Sub ' no data
    
    Dim cCount As Long: cCount = srg.Columns.Count
    If sPDFLeftColumn > cCount Then Exit Sub ' too few columns in Source Range
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drrg As Range: Set drrg = dws.Range(dFirst).Resize(, cCount)
    Dim dPDFRight As String: dPDFRight = "_" & dName & ".pdf"
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range
    Dim dPDFLeft As String
    Dim dFilePath As String
    For Each srrg In srg.Rows
        If Not IsError(srrg.Cells(sPDFLeftColumn)) Then
            dPDFLeft = CStr(srrg.Cells(sPDFLeftColumn).Value)
            If Len(dPDFLeft) > 0 Then
                drrg.Value = srrg.Value
                dws.Calculate
                dFilePath = dFolderPath & dPDFLeft & dPDFRight
                dws.ExportAsFixedFormat _
                    Type:=xlTypePDF, _
                    Filename:=dFilePath, _
                    Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, _
                    IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
            End If
        End If
    Next srrg
    
    Application.ScreenUpdating = True
    
    Dim msg As Long
    msg = MsgBox("Annual statements successfully exported to PDF." & vbLf _
        & "Do you want to explore their location?", _
        vbYesNo + vbInformation + vbDefaultButton2, "Export Annual Statements")
    If msg = vbYes Then
        wb.FollowHyperlink dFolderPath
    End If
    
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range from the first row of a range
'               ('FirstRowRange') through the row range containing
'               the bottom-most non-empty cell in the row's columns.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumns( _
    ByVal FirstRowRange As Range) _
As Range
    If FirstRowRange Is Nothing Then Exit Function
    
    With FirstRowRange.Rows(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , xlByRows, xlPrevious)
        If lCell Is Nothing Then Exit Function ' empty range
        Set RefColumns = .Resize(lCell.Row - .Row + 1)
    End With

End Function