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 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