Excel VBA循环遍历列和保存结果

Question

这对我来说有点难度

我有以下代码，它的工作方式与我想要的类似。但我需要代码循环浏览Sheet1 Column 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