vba - Excel VBA 循环遍历列并保存结果

Question

这对我来说有点挑战

我有以下代码，它就像我想要的那样工作。但我需要代码循环通过 Sheet1 列 A 并将值复制并粘贴到 Sheet2(R1) 然后循环通过 Sheet1 列 B 并将每个值复制到 Sheet2(I7) 然后将工作表保存为新的 PDF 文档

参见图片，例如 excel 表
example

Sub Macro2()
'
' Macro2 Macro
'

'
    Sheets("Sheet1").Select
    Range("A2").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("R1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Calibri"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Sheets("Sheet1").Select
    Range("B2").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("I7").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Calibri"
        .Size = 16
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
        Dim i As Integer
    For i = 1 To 2
    Next i
ThisWorkbook.Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & CStr(i) & ".pdf", _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=True, _
        OpenAfterPublish:=False
    End With
End Sub

Answer 1

如果您在您的 sub 所在的同一“模块”的末尾(在您的实际 sub 下方)添加下面的函数，则可以使用以下代码循环遍历行和/或列。

sub yourcode
    ThisWorkbook.Worksheets("worksheetX").range(col_letter(column_number) & rownumber).Value
end sub

Function col_letter(lngCol As Long) As String 'Sub nr_to_letter()
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
col_letter = vArr(0)
End Function

它会自动将 column_number 转换为 .range(".. 中的列字母。

以下通用代码检测列的最后一行:

    'Find the last used row in a Column: column B in this example
    Dim LastRow As Long
    sheets(name(Sheet)).Select
    sheets(name(Sheet)).Activate

    'MsgBox (Sheet)
    With ActiveSheet
        LastRow = .Cells(.Rows.count, "B").End(xlUp).Row
    End With

通过查找我偶然发现的基本问题的标准解决方案，我学到了很多基础知识:

来源: http://www.rondebruin.nl/

而且我认为这段代码可以执行您想要的任务:

Sub Macro2()
'
' Macro2 Macro
'

'
Sheets("Sheet1").Select
Range("A2").Select

'detect last row in column A sheet1:
Dim LastRow As Long
Sheets("Sheet1").Select
Sheets("Sheet1").Activate

'MsgBox (Sheet)
With ActiveSheet
    LastRow_A = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox (LastRow_A)

'here the function to convert column number to column letter is used:
'Range(col_letter(1) & "2:A" & LastRow).Select
MsgBox ("As you can see the function converts the index of the col_letter to a alphabetic letter: " & col_letter(1))

For loop_through_column_A = 2 To LastRow_A
    Range(col_letter(1) & loop_through_column_A).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("R" & loop_through_column_A - 1).Select 'ensure it starts pasting at row 1
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Calibri"
        .Size = 20
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
Next loop_through_column_A

Sheets("Sheet1").Select
Range("B2").Select


'detect last row in column B sheet1:
Dim LastRow_B As Long
Sheets("Sheet1").Select
Sheets("Sheet1").Activate

'MsgBox (Sheet)
With ActiveSheet
    LastRow_B = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
MsgBox (LastRow_B)

'loop through column Sheet1
For loop_through_column_B = 2 To LastRow_B

    Range("B" & loop_through_column_B).Select
    Selection.Copy
    Sheets("Sheet2").Select

    Range("I" & 5 + loop_through_column_B).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    With Selection.Font
        .Name = "Calibri"
        .Size = 16
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

    'To save the pdf every iteration (after you have already completely iterated through column A in the first for-loop:
    '"Insert here."

Next loop_through_column_B


'include this in the loop if you want to save the pdf every time you add a different pasted row where it says: "Insert here."
ThisWorkbook.Sheets("Sheet2").Select
ActiveSheet.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & CStr(i) & ".pdf", _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=True, _
        OpenAfterPublish:=False

End Sub

'Here the following function IS used:
Function col_letter(lngCol As Long) As String 'Sub nr_to_letter()
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
col_letter = vArr(0)
End Function