Modifying Current Code to Loop To Next Row

user_13429481 0
Viewed 46

I am trying to create a macro that will copy the first row A8:V8 from the [Summary] tab to the [Annual Statement] tab, recalculate, and then save [Annual Statement] tab as pdf with the name of cell A8 from [Summary] tab. This code works as-is for the first row A8:V8. I'd like to make this macro more dynamic and loop to the next row down, A9:V9, and then repeat the same process of copying the values to the [Annual Statement] tab and saving as pdf and then repeat entire process again for the next row down.

Here is the code –

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
vba excel
2 Answers

This code will loop until a blank cell is found in column A on the Summary worksheet.

Option Explicit

Sub AnnualStatements()
Dim RI As Workbook
Dim rngData As Range
Dim strpath As String
Dim strName As String
Dim strFile As String
Dim strPathFile As String

    Set RI = ThisWorkbook

    strpath = "C:Users\Documents\"

    Set rngData = RI.Worksheets("Summary").Range("A8:V8")

    Do
        'Copies over policy information from summary to annual statement tab**
        rngData.Copy RI.Worksheets("Annual Statement").Range("O3")

        Calculate

        ' Create filename for PDF

        strName = rngData.Cells(1,1).Value

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

        strPathFile = strpath & strFile

        ' Saves as pdf**

        RI.Worksheets("Annual Statement").ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=strPathFile, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
                
        Set rngData = rngData.Offset(1)

    Loop Until rngData.Cells(1, 1).Value = ""
    
End Sub
user_28500260

Export Versions of a Worksheet to 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
user_98140690
Related