Excel 将数据复制到新图纸并重新组织它的最佳方法(VBA)

Excel 将数据复制到新图纸并重新组织它的最佳方法(VBA),excel,vba,Excel,Vba,我正在编写一个VBA程序,它将数据从一个主控表复制并组织到多个其他表中。其中一张收件人工作表将主工作表中包含相同id号的所有数据统一到一行中。对于这个操作,我将循环遍历每个id号的主控表,将保存当前id号的每一行复制到一个新的表中,该表纯粹用于计算和组织,并将该表中的数据重新排列到新行中。生成的行将复制到收件人工作表中。组织每个id号的数据的过程需要很长的时间来处理,特别是考虑到此表的很大尺寸以及其他收件人表的处理时间。我想知道是否有更好的方法来组织和复制数据而不使用中间计算表 下面的代码是主s

我正在编写一个VBA程序,它将数据从一个主控表复制并组织到多个其他表中。其中一张收件人工作表将主工作表中包含相同id号的所有数据统一到一行中。对于这个操作,我将循环遍历每个id号的主控表,将保存当前id号的每一行复制到一个新的表中,该表纯粹用于计算和组织,并将该表中的数据重新排列到新行中。生成的行将复制到收件人工作表中。组织每个id号的数据的过程需要很长的时间来处理,特别是考虑到此表的很大尺寸以及其他收件人表的处理时间。我想知道是否有更好的方法来组织和复制数据而不使用中间计算表

下面的代码是主sub,它调用另一个子OrganizeAndCopyToPal,该子OrganizeAndCopyToPal组织计算表中的数据,并将结果复制到收件人工作表中

Sub PalletAssemblyLog()

    Dim allidNum As Range
    Dim curridNum As Range
    Dim rowCount As Long
    Dim idNum
    Dim I As Long
    Dim j As Long
    Dim machineLoc As String
    
    Dim calc As Worksheet
    Dim full As Worksheet
    Dim pal As Worksheet
    Set calc = Sheet3
    Set full = Sheet4
    Set pal = Sheet1
    
    For I = 2 To rowCount
        For j = 2 To rowCount
            If full.Cells(j, 17).Value = idNum Then
                If allidNum Is Nothing Then
                    Set allidNum = full.Cells(j, 17)
                Else
                    Set allidNum = Union(allidNum, full.Cells(j, 17))
                End If
            End If
        Next j
            
        Set curridNum = allidNum.EntireRow
        
        calc.Activate
        calc.Cells.Clear
        
        full.Activate
        curridNum.Copy calc.Range("A1")
        
        OrganizeAndCopyToPal curridNum
    Next I
End Sub
下面的子组织和复制每个id号的数据。复制数据的最后一个子任务与简化此任务无关,因此我不包括它

Sub OrganizeAndCopyToPal(curridNum)
    
    Dim calc As Worksheet
    Dim pal As Worksheet
    Set calc = Sheet3
    Set pal = Sheet1
    
    calc.Activate
    
    Dim rowCount As Long
    rowCount = calc.Cells(Rows.Count, "A").End(xlUp).Row
    
    Dim palRow As Long
    palRow = rowCount + 2
    Dim partRow As Long
    partRow = palRow + 2
    
    Dim currPartCount As Range
    
    Dim assembly As String
    Dim id As String
    Dim location As String
    Dim machType As String
    Dim machLoc As String
    Dim currPart As String
    Dim link As String
    Dim tot As Long
    tot = 0
    
    With calc
        .Cells(1, 1).Copy .Cells(palRow, 2)
        assembly = .Cells(1, 1).Value
        
        .Cells(1, 2).Copy .Cells(palRow, 5)
        
        id = .Cells(1, 17).Value
        
        asArray = SplitMultiDelims(id, "|-")
        'MsgBox asArray(0) & " " & asArray(1) & " " & asArray(2)
        machArray = Split(.Cells(1, 8), "-")
        machType = machArray(0)
        .Cells(palRow, 3) = machType
        
        machLoc = .Cells(1, 8).Value
        .Cells(palRow, 4) = machLoc
        
        .Cells(1, 17).Copy .Cells(palRow, 10)

        location = Cells(1, 9)
        .Cells(palRow, 1) = location
        
        For I = 1 To rowCount
            partArray = Split(.Cells(I, 16).Value, ",")
            For j = 0 To UBound(partArray)
                partArray2 = Split(partArray(0), "-")
                partPrefix = partArray2(0)
                If j = 0 Then
                    currPart = partArray(j)
                Else
                    currPart = partPrefix & "-" & CStr(partArray(j))
                End If
                tf = 1
                For k = 0 To tot
                    If Cells(partRow + k, 1).Value = currPart Then
                        tf = 0
                        Exit For
                    End If
                Next k
                If tf = 1 Then
                    .Cells(partRow + tot, 1).Value = currPart
                    tot = tot + 1
                End If
            Next j
        Next I
        
        For I = 1 To tot
            Cells(palRow, 10 + I).Value = Cells(partRow + I - 1, 1)
        Next I
        
    End With
    
    CopyToPal curridNum, palRow
    
End Sub

感谢您提供的任何提示或帮助。

在进入更奇特的解决方案之前,您可以做的最简单的事情是设置

Application.Calculation = xlCalculationManual
在陷入大量代码之前。 然后,当您需要在复制任何可能因公式计算而更改的数据之前进行更新时,请运行

Application.Calculate
最后,将其重置为

Application.Calculation = xlCalculationAutomatic

您也可以禁用屏幕更新,但上面的内容将是最大的(简单的)一个。之后,我们将复制到数组并在其中工作,然后粘贴回去。

如果代码没有问题,您最好将其发布在•此处,这可能会生成基于意见的答案(这些答案与主题无关)。在您的第一个代码块中,您不会为
idNum
赋值。这是你的真实代码吗?谢谢ᴇʜ,我不知道那是一个单独的论坛,我将在那里转载。Tim,这不是我的实际代码,我删除了无关的部分,但是很好地捕捉到了。大致来说,什么是“长时间”?大约有多少行数据,“id”列的粒度是多少?(例如,每个id一行或两行,一行或二十万行,等等)将有助于了解问题的规模。我仍在开发完整的程序,因此我没有处理完整的数据规模。每个id总是少于10行,并且通常每个id只有一行。总行数可能在1000行左右。