请测试下一种方式。你没有回答我的澄清问题，所以它假设主要任务是那些在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

字符串

作为对你对我的评论的回复的回应-这里有一些使用范围的方法。这包括@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

字符串