Question

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

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

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

End Sub

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

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

1 个答案: