Excel 宏将数据从一张纸移动到另一张纸的速度非常慢

Question

`我得到了一份带有 ID 的 Excel 表格，并以概述的格式关联了其他 ID。
例如

在此图像中 - 5647326 是主 ID，关联 ID 是 8798965，它们按轮廓分组。

我有一个要求，我需要以线性格式将数据从该工作表传输到同一工作簿中的其他工作表 - 就像在原始 Excel 中一样，我们在一行中获得主 ID，在下一行中获得关联 ID，在新工作表主 ID 和关联 ID 中应该在同一行，如果有多个关联 ID，则主 ID 应添加两次，并在相应行中添加 2 个关联 ID，如

我们开发了一个宏，运行良好，但速度非常慢，例如 500 行需要 4-5 分钟。 任何人都可以帮助我如何提高以下宏的性能（从 A6 开始输入工作表数据，因为前 5 行具有可以从传输到其他工作表跳过的通用信息：

Private Sub Workbook_Open() 
' ' MoveRows Macro ' 
' Keyboard Shortcut: Ctrl+w

Dim lastrow As Long 
Dim lastcol As Long 
Dim i As Integer 
Dim iNewRow As Integer 
Dim ws As Worksheet 
Dim cell As Range
Dim row As Long 
Dim crtLvl As Integer 
Dim rgRow As Range 
Dim orgSelect As Range

lastrow = Sheet1.Cells(Rows.Count, 3).End(xlUp).row 
lastcol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column

'MsgBox lastrow

'Delete all worksheets other than Sheet1 
Application.DisplayAlerts = False 
For Each ws In Worksheets 
If ws.Name <> "Sheet1" 
Then ws.Delete 
End If 
Next 
Application.DisplayAlerts = True

'Create a new worksheet 
Sheets.Add(after:=Sheet1).Name = "Export" 
With Sheets("Export") 
.Range("A1") = "ID" 
.Range("B1") = "Name" 
.Range("C1") = "Type" 
.Range("D1") = "Owner" 
.Range("E1") = "Task Status" 
.Range("F1") = "Associated Resource ID" 
.Range("G1") = "Associated Resource Name" 
.Range("H1") = "Associated Resource Type" 
.Range("I1") = "Associated Resource Owner" 
.Range("J1") = "Associated Resource Status"

.Range("A1:J1").Interior.ColorIndex = 8
End With

i = 6 
iNewRow = 2 
Dim sht As Worksheet 
Dim Lr As Long 
Dim Lc As Long 
Dim FirstCell As Range
Set sht = Worksheets("Sheet1") 
Set FirstCell = Range("A6") 
Dim inp As Integer 
Dim iFirstLevelRow As Integer

With Sheet1 
For Each cell In .Range("a6", .Cells(lastrow, lastcol)) 
'rg2c = Range(FirstCell, .Cells(i, 1).Select) 
rangeName = i & ":" & i 
rg2c = Worksheets("Sheet1").Range(rangeName)

inp = Worksheets("Sheet1").Rows(i).OutlineLevel 

If i <= lastrow Then
   If inp = 1 Then
   iFirstLevelRow = cell.row
  
        i = i + 1
 End If
  If inp = 2 Then
  .Cells(iFirstLevelRow, 1).Copy Sheets("Export").Cells(iNewRow, 1)
        .Cells(iFirstLevelRow, 2).Copy Sheets("Export").Cells(iNewRow, 2)
        .Cells(iFirstLevelRow, 3).Copy Sheets("Export").Cells(iNewRow, 3)
           .Cells(iFirstLevelRow, 4).Copy Sheets("Export").Cells(iNewRow, 4)
           .Cells(iFirstLevelRow, 5).Copy Sheets("Export").Cells(iNewRow, 5)
           .Cells(iFirstLevelRow, 6).Copy Sheets("Export").Cells(iNewRow, 6)
  .Cells(cell.row, 1).Copy Sheets("Export").Cells(iNewRow, 7)
        .Cells(cell.row, 2).Copy Sheets("Export").Cells(iNewRow, 8)
        .Cells(cell.row, 3).Copy Sheets("Export").Cells(iNewRow, 9)
         .Cells(cell.row, 4).Copy Sheets("Export").Cells(iNewRow, 10)
        i = i + 1
        iNewRow = iNewRow + 1
 End If
 End If

Next

End With

Worksheets("Export").UsedRange.EntireColumn.AutoFit
Worksheets("Export").UsedRange.EntireRow.AutoFit 
End Sub

Answer 1

为了回应您对我的评论的回复 - 以下是使用范围的方法。这包括@lorenz albert 的建议（已投票）

Sub demo()

    'Method 1 - use the Range to copy/paste instead of column by column or row by row
    ThisWorkbook.Sheets("Sheet1").Range("A4:I5").Copy ThisWorkbook.Sheets("Sheet2").Range("A3:I4")

    'Method 2 - assign the values directly
    ThisWorkbook.Sheets("Sheet2").Range("A5:I6").Value = ThisWorkbook.Sheets("Sheet1").Range("A6:I7").Value
    
    'Method 3 - use arrays as an intermediary - useful if you need to examine or amend the contents of any cells first
    Dim vArr As Variant
    vArr = ThisWorkbook.Sheets("Sheet1").Range("A8:I9").Value
    ThisWorkbook.Sheets("Sheet2").Range("A7:I8").Value = vArr

End Sub

Answer 2

请测试下一个方法。您没有回答我的澄清问题，因此假设主要任务是 C:C 栏中具有“任务”的任务。即使对于大范围的处理，它也应该非常快。使用数组并立即删除处理后的数组内容，它主要在内存中工作：

Sub ProcessTasks()
  Dim ws As Worksheet, destws As Worksheet, lastR As Long, i As Long, iRow As Long, rg As Range
  Dim arr, arr1, arrTsk, arrIt, arrHd, arrFin, dKey, dict As Object
  
  Set ws = ActiveSheet 'use here the sheet you need
  Set destws = ws.Next 'destination sheet (here, the next one)
  destws.UsedRange.Clear
  
  Set rg = ws.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious)
  lastR = rg.Row 'last row (hidden rows included)
  
  arr = ws.Range("A2:E" & lastR).Value2
  
  Set dict = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(arr)
    If arr(i, 3) = "Task" Then
        arrTsk = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
        dict(arr(i, 1)) = Array(arrTsk, Array(""))
        dKey = arr(i, 1)
    Else
        arrIt = dict(dKey)
        If Not IsArray(arrIt(1)(0)) Then
            arrIt(1)(0) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
            dict(dKey) = arrIt
        Else
            arr1 = arrIt(1)
            ReDim Preserve arr1(UBound(arr1) + 1)
            arr1(UBound(arr1)) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
            arrIt(1) = arr1:  dict(dKey) = arrIt
        End If
        iRow = iRow + 1
    End If
  Next i
  
  ReDim arrFin(1 To iRow + 1, 1 To 10) 'redim the final array according to the determined number of rows (iRow)
  
  'Load headers array:
  arrHd = Split("ID,Name,Type,Owner,Task Status,Associated Resource ID,Associated Resources Name,Associated Resource Type, Associated Resource Owner,Associated Resource Status", ",")
  
  'load the final aray header:
  For i = 0 To UBound(arrHd)
    arrFin(1, i + 1) = arrHd(i)
  Next i
  
  'process the dictionary items:
  Dim k As Long, m As Long, j As Long: k = 1
  For i = 0 To dict.count - 1
    For m = 0 To UBound(dict.Items()(i)(1))
        k = k + 1
        'fill the final array first 5 columns corresponding to the main IDs:
        For j = 0 To UBound(dict.Items()(i)(0))
            arrFin(k, j + 1) = dict.Items()(i)(0)(j): 'Stop
        Next j
        'fill the rest of the final array columns corresponding to associated IDs
        For j = 0 To UBound(dict.Items()(i)(1)(m))
            arrFin(k, j + 6) = dict.Items()(i)(1)(m)(j): 'Stop
        Next j
    Next m
  Next i
  
  'Drop the final array content, at once:
  With destws.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2))
    .Value2 = arrFin
    .EntireColumn.AutoFit
  End With
  
  MsgBox "Ready..."
End Sub