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