從多個行循環複製粘貼它們在同一行中單獨...

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