Question

我有这个文件，我需要多次将其从一个标签复制并粘贴到另一个标签。我是VBA编码的新手，因此为每个类别提供了一个for循环。但是花了35分钟才能完成运行。结果是正确的，但是运行时间太长。

我在我的代码中包括了screenupdating = False，enableevents = false和手动计算。但这对运行时间没有帮助。

Sub Copyplans（）

Dim cntplan As Integer
Dim tot_year As Integer
Dim tot_quarter As Integer
Dim tot_age As Integer
Dim tot_plan As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim quarter_row As Long
Dim quarter_rows As Long
Dim s1 As Worksheet
Dim s2 As Worksheet 

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual


Set s1 = Sheet1
Set s2 = Sheet2
Set bs = Sheet4
Set bafs = Sheet5
Set s1ope = Sheet6

cntplan = Excel.WorksheetFunction.CountA(s2.Range("A:A")) 
tot_year = cntplan * 66 * 4 
tot_quarter = cntplan * 66 
tot_age = cntplan * 4

'copy current year
For i = 1 To tot_year
s2.Range("Current_year").Copy
s1.Range("A" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

'copy version
For i = 1 To tot_year
s2.Range("version").Copy
s1.Range("C" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

'copy quarter 1 to 4
For i = 1 To 4
   For j = 1 To tot_quarter
   quarter_row = s1.Range("B" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("H" & i).Copy
   s1.Range("B" & quarter_row).PasteSpecial Paste:=xlPasteValues
   Next j
Next i


'copy age 0-65
For i = 1 To tot_age
   For j = 1 To 66
   quarter_row = s1.Range("F" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("K" & j).Copy
   s1.Range("F" & quarter_row).PasteSpecial Paste:=xlPasteValues
   Next j
Next i



'copy IDs
For i = 1 To 4
   For j = 1 To cntplan
     For k = 1 To 66
   quarter_rows = s1.Range("D" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("A" & j).Copy
   s1.Range("D" & quarter_rows).PasteSpecial Paste:=xlPasteValues
   Next k
   Next j
Next i


'copy Names
For i = 1 To 4
   For j = 1 To cntplan
     For k = 1 To 66
   quarter_rows = s1.Range("E" & Rows.Count).End(xlUp).Offset(1).Row
   s2.Range("B" & j).Copy
   s1.Range("E" & quarter_rows).PasteSpecial Paste:=xlPasteValues
   Next k
   Next j
Next i

结束子

我有43个具有唯一ID的计划，这些计划适用于0-65岁年龄段和4个季度。我的最终结果是11352行= 66（年龄）* 43个计划* 4个季度

第一列：年份，都相同
第二栏：1-4个季度，应为1s的2838，然后为2s的2838 ... 第三栏：全1 第4栏：43个ID，每个季度每个ID有66行第5栏：43个名称，与ID相同第六列：66个年龄段（0-65），172个0-65个年龄段行

有人可以给我一些减少运行时间的建议吗？

谢谢， SC

Answer 1

例如：

'copy current year
For i = 1 To tot_year
s2.Range("Current_year").Copy
s1.Range("A" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

'copy version
For i = 1 To tot_year
s2.Range("version").Copy
s1.Range("C" & i + 1).PasteSpecial Paste:=xlPasteValues
Next i

会更快：

s1.Range("A2").Resize(tot_year, 1).Value = s2.Range("Current_year").Value
s1.Range("C2").Resize(tot_year, 1).Value = s2.Range("version").Value

减少VBA运行时间

1 个答案: