excel - 打印 VBA 时为每一行编号

Question

我在两列(myrange1 和 myrange2)中找到匹配项，将它们填充到 sheet2 的第三列(“R”)中。我的范围从“R”列打印到 PDF 就好了，但我希望每个在 PDF 上按顺序编号，即 1、2、3、4 等。非常感谢帮助。 VBA 也很新。

Sub matchcopy()
    Dim myrange1 As Range, myrange2 As Range, cell As Range

    With Sheets("Sheet1")
        Set myrange1 = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With

    With Sheets("Sheet2")
        Set myrange2 = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
    End With

    For Each cell In myrange1
        If Not IsError(Application.Match(cell.Value, myrange2, 0)) Then  
            'cell.Value, myrange2, 0
            cell.Copy
            Sheet2.Range("R5000").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        Else
            'MsgBox "no match is found in range"
        End If
    Next cell

    Columns("R:R").EntireColumn.AutoFit
    Call Set_PrintRnag
End Sub


Sub Set_PrintRnag()
    Dim LstRw As Long
    Dim Rng As Range

    LstRw = Cells(Rows.Count, "R").End(xlUp).Row
    Set Rng = Range("R1:R" & LstRw)

    With ActiveSheet.PageSetup
        .LeftHeader = "&C &B &20 Cohort List Report : " & Format(Date, 
    "mm/dd/yyyy")
    End With

    Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & _
      "\CohortList " & " " & Format(Date, "mm-dd-yyyy") & ".pdf", _
      Quality:=xlQualityStandard, IncludeDocProperties:=True, _
      IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

Answer 1

尽可能接近您的代码，尽管循环遍历一个范围总是很耗时，并且您可以更快地处理要比较的列的数组:

Option Explicit

Sub matchcopy()
    Dim i&
    Dim myrange1 As Range, myrange2 As Range, cell As Range
  ' You can use the Codenames instead of Worksheet("Sheet1") etc.
    Set myrange1 = Sheet1.Range("A1", Sheet1.Range("A" & Rows.Count).End(xlUp))
    Set myrange2 = Sheet2.Range("A1", Sheet2.Range("A" & Rows.Count).End(xlUp))
    Sheet2.Range("R:S") = ""                 ' <~~ clear result columns

    For Each cell In myrange1               ' presumably unique items
        If Not IsError(Application.Match(cell.Value, myrange2, 0)) Then
            cell.Copy
            With Sheet2.Range("R5000").End(xlUp)
                i = i + 1                   ' <~~ counter
                .Offset(1, 0) = i           ' counter i equals .Row - 1
                .Offset(1, 1).PasteSpecial xlPasteFormulasAndNumberFormats
            End With
        Else
            'MsgBox "no match is found in range"
        End If
    Next cell

    Sheet2.Columns("R:S").EntireColumn.AutoFit
    Call Set_PrintRnag                      ' called procedure see OP
End Sub

Sub Set_PrintRnag()
Dim LstRw As Long
Dim Rng As Range

LstRw = Sheet2.Cells(Rows.Count, "R").End(xlUp).Row
Set Rng = Sheet2.Range("R1:S" & LstRw)

With Sheet2.PageSetup
    .LeftHeader = "&C &B &20 Cohort List Report : " & Format(Date, "mm/dd/yyyy")
End With

Rng.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & _
  "\CohortList " & " " & Format(Date, "mm-dd-yyyy") & ".pdf", _
  Quality:=xlQualityStandard, IncludeDocProperties:=True, _
  IgnorePrintAreas:=False, OpenAfterPublish:=True
End Sub

附加提示

要了解如何使用数据字段数组，请参阅例如所以回答 Loop with multiple ranges