宏执行直到循环 从值列表中复制粘贴到单个单元格(例如 b1)

Question

这是我在这里的第一篇文章，以便您提前提供帮助。多么棒的社区！

我正在尝试编写一个宏，该宏将循环访问不确定行数的值列表，并逐个将值复制并粘贴到单个单元格中，每次通过循环替换刚刚粘贴到单个单元格中的值，该值由报告模板引用并根据数字的 id 自动填充数据

下面是表格外观的示例：

__|__A__|__B__
1 | 231 | 234
2 | 232 |
3 | 233 |
4 | 234 |
5 | 235 |
6 | 236 |

231 将被复制并粘贴到 B1 中，然后 232 将被复制并粘贴到 B1 中，然后 233 将被复制并粘贴到

B1 中，然后 234 将被复制并粘贴到 B1.....等等等等。在复制和过去的步骤之间，还有其他步骤可以将图像添加到工作表并另存为 pdf。

我编写了这个脚本来实现目标：

Sub Report()
'
' Report Macro
'
' Keyboard Shortcut: Ctrl+Shift+G
'
' this section just copies a selection of cells from on worksheet and moves it to another worksheet filters it and copies filtered list to yet another worksheet.
Application.ScreenUpdating = False
Selection.Copy
Sheets("Master Sheet").Select
Range("A6").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("$A$5:$BS$410").AutoFilter Field:=7, Criteria1:="2"
Selection.Copy
Sheets("Report").Select
Range("A1").Select
ActiveSheet.Paste
' This section does the operation outlined at beginning of post.
Range("A1").Select
Do Until IsEmpty(ActiveCell.Value)
    Selection.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.Run "PERSONAL.XLSB!ErasePhoto"
    Application.Run "PERSONAL.XLSB!PhotoPlace"
    ActiveWindow.ScrollRow = 1
    Application.CutCopyMode = False
    ChDir "C:"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("B3").Value          _
    , Quality:=xlQualityStandard, IncludeDocProperties:=True,  IgnorePrintAreas _
    :=False, OpenAfterPublish:=True
    Application.Run "PERSONAL.XLSB!ErasePhoto"
    ActiveCell.Offset(1, 0).Select
Loop
End Sub

当我运行宏时，它成功通过一次，但没有循环。我不知道为什么？谢谢！！！！

Answer 1

逐步执行代码以查看执行循环时哪些单元格是活动单元格？代码将 B1 设置为每个循环中的活动单元格。如果不知道被调用的过程做了什么，就很难说出哪个细胞在循环之前受到ActiveCell.Offset(1, 0).Select的影响。

代码中有很多不必要的选择和激活语句。清理它。

Answer 2

好的，所以我能够在一个 excel 论坛上从一个名叫 skywriter 的非常善良的人那里找到答案。它就像一个魅力。

Dim r As Range 
For Each r In Range("A1", Range("A" & Rows.Count).End(xlUp)) 
    Range("B1").Value = r.Value 
    Application.Run "PERSONAL.XLSB!ErasePhoto" 
    Application.Run "PERSONAL.XLSB!PhotoPlace" 
    ActiveWindow.ScrollRow = 1 
    Application.CutCopyMode = False 
    ChDir "C:" 
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF,       Filename:=Range("B3").Value _ 
    , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _ 
    :=False, OpenAfterPublish:=True 
    Application.Run "PERSONAL.XLSB!ErasePhoto" 
Next r

Answer 3

我通过添加一个 counter 变量在您的代码中进行了一个小的更改，然后在 Do Until 循环中使用。这使您可以使用 Offset 选择所需的单元格。

' This section does the operation outlined at beginning of post.
Range("A1").Select
Dim counter As Long    '---->line added
counter = 1            '---->line added
Do Until IsEmpty(ActiveCell.Value)
    Selection.Copy
    Range("B1").Select
    ActiveSheet.Paste
    Application.Run "PERSONAL.XLSB!ErasePhoto"
    Application.Run "PERSONAL.XLSB!PhotoPlace"
    ActiveWindow.ScrollRow = 1
    Application.CutCopyMode = False
    ChDir "C:"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Range("B3").Value _
    , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=True
    Application.Run "PERSONAL.XLSB!ErasePhoto"
    ActiveCell.Offset(counter, -1).Select    '----> make change here
    counter = counter + 1                    '----> line added
Loop