从多个行循环复制粘贴它们在同一行中单独...

Question

.....在单独的工作簿上无限期地。

你好首先我是新来的，VBA很新。我有一个工作簿，其中有一个名为“book1”的列表，我编写的代码从该书中的一个范围中获取数据，并将其粘贴到另一本书“DMAutocalcs”中，每次一个特定的行，代码会执行刷新和等待时间，之后它会将“DMautoCalcs”中特定范围内的某个定价日期复制回Book1。截至现在，我手动复制代码并修改它需要传输的每个呼叫范围。所以存在这个问题，本质上它会受到我希望复制我现有的次数的限制。我打算修改代码以循环并在工作簿之间执行复制粘贴，直到它到达“book1”中的空单元格。但是，我所做的每一次尝试都失败了，它只会一遍又一遍地反复使用相同的范围，除非手动复制代码并修改每一个新行。我担心我没有完全理解范围行和单元方面，当涉及亲属和绝对时，以及如何准确地调用out的正确语法。 我该如何做到这一点？任何帮助，将不胜感激。

Public Sub macro_54() 
' Keyboard Shortcut: Ctrl+p 
Dim StartTime As Double 
Dim SecondsElapsed As Double 

StartTime = Timer 

Workbooks.Open ("C:\Users\Legacy\Desktop\DMAutoCalcs.xlsm") 

Windows("Book1.xlsm").Activate 
Range("a2:l2").Select 
Selection.Copy 
Windows("DMAutoCalcs.xlsm").Activate 
Range("a1:q1").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
         :=False, Transpose:=False 
'Refresh 
ActiveWorkbook.RefreshAll 
Application.Wait (Now + TimeValue("0:00:03")) 
ActiveWorkbook.RefreshAll 

Windows("DMAutoCalcs.xlsm").Activate 
Range("T2:x2").Select 
'Application.CutCopyMode = False 
Selection.Copy 
Windows("Book1.xlsm").Activate 
Range("M2:q2").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
         :=False, Transpose:=False 
' copy from calcs pricing info and past into pricelist 
' return to pricelist 
' Selects cell down 1 row from active cell. 
'New Line 
Windows("Book1.xlsm").Activate 
Range("a3:l3").Select 
Selection.Copy 
Windows("DMAutoCalcs.xlsm").Activate 
Range("a1:q1").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
         :=False, Transpose:=False 
' Refresh 

ActiveWorkbook.RefreshAll 
Application.Wait (Now + TimeValue("0:00:03")) 
ActiveWorkbook.RefreshAll 

Windows("DMAutoCalcs.xlsm").Activate 
Range("T2:x2").Select 
'Application.CutCopyMode = False 
Selection.Copy 
Windows("Book1.xlsm").Activate 
Range("M3:q3").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
         :=False, Transpose:=False 

' copy from calcs pricing info and past into pricelist 
' return to pricelist 
' Selects cell down 1 row from active cell. 

'New Line 
Windows("Book1.xlsm").Activate 
Range("a4:l4").Select 
Selection.Copy 
Windows("DMAutoCalcs.xlsm").Activate 
Range("a1:q1").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
         :=False, Transpose:=False 
' Refresh 
ActiveWorkbook.RefreshAll 

Application.Wait (Now + TimeValue("0:00:03")) 

ActiveWorkbook.RefreshAll 

Windows("DMAutoCalcs.xlsm").Activate 
Range("T2:x2").Select 
'Application.CutCopyMode = False 
Selection.Copy 
Windows("Book1.xlsm").Activate 
Range("M4:q4").Select 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ 
         :=False, Transpose:=False 

' copy from calcs pricing info and past into pricelist 
' return to pricelist 
' 
' Selects cell down 1 row from active cell. 
' And so on and so forth.... 
Windows("DMAutoCalcs.xlsm").Activate 
ActiveWorkbook.Close savechanges:=False 
Windows("Book1.xlsm").Activate 
'Determine how many seconds code took to run 
SecondsElapsed = Round(Timer - StartTime, 2) 
'Notify user in seconds 
MsgBox "All Ranges Updated, Calc sheet closed successfully in " & SecondsElapsed & " seconds", vbInformation 

末次

Answer 1

你不必选择或复制和粘贴前启动一个范围或窗口。下面是我能理解你的修改后的代码。

Sub macro_54_Modified() 
'Let your working sheets in Book1 and DMAutoCalcs are Sheet1 and Sheet2, respectively 

    Workbooks.Open "C:\Users\Legacy\Desktop\DMAutoCalcs.xlsm" 

    Dim wsDm As Worksheet, wsB1 As Worksheet, lastRow As Long, i As Long 
    Set wsB1 = Workbooks("Book1.xlsm").Sheets("Sheet1") 
    Set wsDm = Workbooks("DMAutoCalcs.xlsm").Sheets("Sheet2") 

    'Last row number in column A 
    lastRow = wsB1.Cells(Rows.Count, 1).End(xlUp).Row 

    For i = 2 To lastRow 
     wsB1.Range("A2:L2").Offset(i - 2).Copy wsDm.Range("a1:q1") 
     'VBA code for Refresh ... ? 
     wsDm.Range("T2:X2").Copy wsB1.Range("M2:q2").Offset(i - 2) 
    Next i 
End Sub