Macro Do Until Loop从值列表复制粘贴到单元格中（例如b1）

问题描述：

这是我第一篇文章，以便您提前寻求帮助。多么伟大的社区！Macro Do Until Loop从值列表复制粘贴到单元格中（例如b1）

我想写一个宏，将通过未确定数量的行的值列表循环，并逐个复制并将值粘贴到单个单元格中，每次通过循环替换刚刚粘贴的值进入单细胞，它是由一个报告模板和自动填充数据，基于数

这里的ID引用是表将是什么样子的例子：

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

231将复制并粘贴到B1中，然后将232复制并粘贴到B1中，然后将233复制并粘贴到B1中，然后234将b e复制并粘贴到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

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

感谢德克修复格式，我是新来的，所以我可以得到的所有帮助表示赞赏。 –

答

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

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

答

好的，所以我可以在一个名叫skywriter的奇妙人物的excel论坛上找到答案。它像一个魅力。

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

答

我已经加入了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

Macro Do Until Loop从值列表复制粘贴到单元格中（例如b1）

相关推荐