如何根据满足特定条件的列将 2 列数组的值分配给单列数组
How to assign values from a 2 column array to a single column array based on a column meeting certain criteria
我需要制作一个宏，从 A 列收集部件号，并每隔 8 个空格将它们粘贴到另一个 sheet 上。问题是我需要根据订单代码执行此操作：A11、A21、A31、B11、B21、B31、C11、C21、C31、C12、C22、C32、C13、C23、C33（位于 B 列）每个sheet，一共有5个sheet分组如下： Sheet 'A##'包含所有以“A”开头的代码。 Sheet 'B##' 包含所有带“B”的代码。 Sheet 'C#1' 包含所有以 C 开头，以 1 结尾的代码，依此类推。这需要为大约 12000 个零件完成。根据我对 Excel VBA 的了解，我相信数组是完成此操作的最快方法。
订单代码的示例是“A11”、“A12”、“A13”，因为这 3 个代码需要发送给另一个 sheet。我已经使用通配符来限制过滤（即“A**”代表“A13”、“A23”等）。
下面是我目前用来完成此任务的代码，以及其他宏和所有循环，宏的第一个 运行 花了我 1 小时 5 分钟。但是，这个宏需要每月 运行 一次，并且使用相同的工作簿，所以我 运行 第二次“刷新”数据，这需要 3.5 小时。现在它不再 运行 所以我不得不寻找其他方法来加速它。
在下面的代码中，wb = active workbook 和 Sht 是 sheet 我想要的代码。我这样写是因为我将其作为一个 excel 加载项，而不仅仅是工作簿中的一个模块。
Public Sub SetupSheetA()
Set wb = ActiveWorkbook
Set Sht = wb.Worksheets("A##")
Code = "A**"
'Grab endRow value for specific sheet designated by the order code
With wb.Worksheets("SO Hits Data Single Row")
endRow = 1 + 8 * Application.WorksheetFunction.CountIf(.Range("B4:B999999"), Code)
End With
Sht.Cells.Clear 'Clear sheet contents
'Macros
Call PartInfo
'Other macros not relevant to this question
End Sub
Public Sub PartInfo()
'***********************************************************************************************************
'Collect Part #, order code, vendor info, and WH Info
'***********************************************************************************************************
Dim j As Long, i As Long
j = Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A999999"))
With Sht
'Part #
CurrentPartRow = 2
For i = 4 To j
If Sheets("SO Hits Data Single Row").Range(Cells(i, 2).Address) Like Code Then
.Range(Cells(CurrentPartRow, 1).Address).Value = "='SO Hits Data Single Row'!" & Cells(i, 1).Address
CurrentPartRow = CurrentPartRow + 8
End If
Next i
'Order code
.Range("A3").Value = "=VLOOKUP(A2,'SO Hits Data Single Row'!$A:$B,2,FALSE)"
'Copy to Next Row
For CurrentPartRow = 10 To endRow - 7 Step 8
'Order code CopyPaste
.Range("A3").Copy Destination:=.Range(Cells(CurrentPartRow + 1, 1).Address
Next CurrentPartRow
End With
End Sub
我试图通过将工作簿另存为 .xlbs 来加快速度，这将文件大小从 240MB 减小到 193MB。然后我删除了所有我可以逃脱的数据，并删除了任何不必要的格式，这些格式进一步将文件减少到 163MB，然后删除宏正在粘贴数据的 sheets 将文件减少到 73MB。
即使使用这个小得多的文件，尽管 运行 整个周末都在使用它，宏仍然会挂起并且不会响应。
我还尝试使用以下代码过滤数组：
Dim arr1 As Variant, arr2 As Variant, i As Long, code As String
code = "A**" 'For any order codes containing A11, A12, A13, A21, A22, _
A23, etc
Lastrow = Sheets("SO Hits Data Single Row").Cells(Rows.Count, _
1).End(xlUp).Row
arr1 = Sheets("SO Hits Data Single Row").Range("B4:B" & Lastrow).Value
arr2 = Filter(arr1, code)
Sheets("A##").Range("a1") = arr2
但它只是给出了一个不匹配的错误。
下面是我需要实现的输出示例。
如果你有 Excel 2019 或 Excel 365，那么你可以使用 built-in SORT 和 FILTER 函数来大大简化事情：
Public Function PartsToSheet(OrderPrefix AS String) AS Boolean
PartsToSheet = False
On Error GoTo FuncErr 'Return False if there is an error
Dim calcTMP As xlCalculation
calcTMP = Application.Calculation
'Only Calculate Formulae when we explicitly say to
Application.Calculation = xlCalculationManual
Dim wsSource AS Worksheet, wsDestination AS Worksheet
Dim lParts AS Long, lRecords AS Long
Dim adTable AS String, adOrders AS String
Set wsSource = ThisWorkbook.Worksheets("SO Hits Data Single Row")
Set wsDestination = ThisWorkbook.Worksheets(OrderPrefix & "##")
'Prepare the Destination
With wsDestination
'Deleting Rows & Columns frees up the Used Range, freeing more memory than Clear does
.Range(.Cells(1, 1), .Range(.Rows.Count, 1)).EntireRow.Delete
.Range(.Cells(1, 1), .Range(1, .Columns.Count)).EntireColumn.Delete
End With
lParts = Application.CountA(wsSource.Columns(1))
lRecords = Application.CountIf(wsSource.Columns(2), OrderPrefix & "*")
adTable = wsSource.Range(wsSource.Cells(1, 1),wsSource.Cells(lParts, 2)).Address(True, True, xlA1, True)
adOrders = wsSource.Range(wsSource.Cells(1, 2),wsSource.Cells(lParts, 2)).Address(True, True, xlA1, True)
If lRecords > 0 Then 'If there are Order Codes for this Sheet
wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Formula = _
"=IF(MOD(ROW()+6,8)>0, """", INDEX(SORT(" & _
"FILTER(" & adTable & ", LEFT(" & adOrders & ", 1)=""" & OrderPrefix & """)" & _
", 2), (ROW()+6)/8, 1))"
wsDestination.Columns(1).Calculate 'Explicitly calculate formulae
wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Value = _
wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Value
End If
PartsToSheet = True 'Success!
FuncErr:
On Error GoTo -1 'Clear any errors in the handler
Application.Calculation = calcTMP
End Function
基本上，我们用一个将空白 7 行的函数 (IF(MOD(ROW()+6,8)>0,) 填充目标 sheet 的第一列，然后提供下一个条目 (INDEX(.., (ROW()+6)/8, 1))在一个数组中，我们通过 FILTERing 获取前缀，SORTing 获取订单代码。
然后我们通过将结果从动态公式转换为静态值来“扁平化”结果。
因此，我发现数组实际上是解决此问题的最佳方法。但是，文件大小显然是一个主要问题，我发现这是由于当前选择中包含了空白单元格。一旦我更快地修复了宏 运行 但仍然花费了太长时间。我最终编写了代码以将数据保存到一个数组中，然后稍后以类似于以下的方式对其进行过滤。
Sub Example()
Dim arr1 As Variant, arr2(10000) As Variant, i As Long, j As Long, k As Long, Filter As String
Application.ScreenUpdating = False 'Freeze screen while macro runs
Application.EnableEvents = False 'Disable popups
Application.Calculation = xlManual 'Disable Sheet calcs
Filter = "A**"
arr1 = ActiveWorkbook.Worksheets("Sheet1").Range("A4:B12000").Value
j= Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A20000"))
For i = 1 To j
If arr1(i, 2) Like Filter Then
arr2(k) = arr1(i, 1)
arr2(k + 1) = ""
arr2(k + 2) = ""
arr2(k + 3) = ""
arr2(k + 4) = ""
arr2(k + 5) = ""
arr2(k + 6) = ""
arr2(k + 7) = ""
k = k + 8 'This was so I could adjust for the blank spaces I needed between each value in the array
End If
Next i
Application.ScreenUpdating = True 'Unfreeze screen
Application.Calculation = xlAutomatic 'Enable Sheet calcs
Application.EnableEvents = True 'Enable popups
End Sub
上面的代码更适合我的情况，但下面是供以后查看者使用的更通用的形式。
Sub Example()
Dim arr1 As Variant, arr2(10000) As Variant, i As Long, j As Long, k As Long, Filter As String
Application.ScreenUpdating = False 'Freeze screen while macro runs
Application.EnableEvents = False 'Disable popups
Application.Calculation = xlManual 'Disable Sheet calcs
Filter = "A**" 'This is where you would put your filter instead of "A**"
arr1 = ActiveWorkbook.Worksheets("Sheet1").Range("A4:B12000").Value
j= Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A20000"))
For i = 1 To j
If arr1(i, 2) Like Filter Then
arr2(k) = arr1(i, 1)
End If
Next i
Application.ScreenUpdating = True 'Unfreeze screen
Application.Calculation = xlAutomatic 'Enable Sheet calcs
Application.EnableEvents = True 'Enable popups
End Sub
我需要制作一个宏，从 A 列收集部件号，并每隔 8 个空格将它们粘贴到另一个 sheet 上。问题是我需要根据订单代码执行此操作：A11、A21、A31、B11、B21、B31、C11、C21、C31、C12、C22、C32、C13、C23、C33（位于 B 列）每个sheet，一共有5个sheet分组如下： Sheet 'A##'包含所有以“A”开头的代码。 Sheet 'B##' 包含所有带“B”的代码。 Sheet 'C#1' 包含所有以 C 开头，以 1 结尾的代码，依此类推。这需要为大约 12000 个零件完成。根据我对 Excel VBA 的了解，我相信数组是完成此操作的最快方法。
订单代码的示例是“A11”、“A12”、“A13”，因为这 3 个代码需要发送给另一个 sheet。我已经使用通配符来限制过滤（即“A**”代表“A13”、“A23”等）。
下面是我目前用来完成此任务的代码，以及其他宏和所有循环，宏的第一个 运行 花了我 1 小时 5 分钟。但是，这个宏需要每月 运行 一次，并且使用相同的工作簿，所以我 运行 第二次“刷新”数据，这需要 3.5 小时。现在它不再 运行 所以我不得不寻找其他方法来加速它。
在下面的代码中，wb = active workbook 和 Sht 是 sheet 我想要的代码。我这样写是因为我将其作为一个 excel 加载项，而不仅仅是工作簿中的一个模块。
Public Sub SetupSheetA()
Set wb = ActiveWorkbook
Set Sht = wb.Worksheets("A##")
Code = "A**"
'Grab endRow value for specific sheet designated by the order code
With wb.Worksheets("SO Hits Data Single Row")
endRow = 1 + 8 * Application.WorksheetFunction.CountIf(.Range("B4:B999999"), Code)
End With
Sht.Cells.Clear 'Clear sheet contents
'Macros
Call PartInfo
'Other macros not relevant to this question
End Sub
Public Sub PartInfo()
'***********************************************************************************************************
'Collect Part #, order code, vendor info, and WH Info
'***********************************************************************************************************
Dim j As Long, i As Long
j = Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A999999"))
With Sht
'Part #
CurrentPartRow = 2
For i = 4 To j
If Sheets("SO Hits Data Single Row").Range(Cells(i, 2).Address) Like Code Then
.Range(Cells(CurrentPartRow, 1).Address).Value = "='SO Hits Data Single Row'!" & Cells(i, 1).Address
CurrentPartRow = CurrentPartRow + 8
End If
Next i
'Order code
.Range("A3").Value = "=VLOOKUP(A2,'SO Hits Data Single Row'!$A:$B,2,FALSE)"
'Copy to Next Row
For CurrentPartRow = 10 To endRow - 7 Step 8
'Order code CopyPaste
.Range("A3").Copy Destination:=.Range(Cells(CurrentPartRow + 1, 1).Address
Next CurrentPartRow
End With
End Sub
我试图通过将工作簿另存为 .xlbs 来加快速度，这将文件大小从 240MB 减小到 193MB。然后我删除了所有我可以逃脱的数据，并删除了任何不必要的格式，这些格式进一步将文件减少到 163MB，然后删除宏正在粘贴数据的 sheets 将文件减少到 73MB。 即使使用这个小得多的文件，尽管 运行 整个周末都在使用它，宏仍然会挂起并且不会响应。
我还尝试使用以下代码过滤数组：
Dim arr1 As Variant, arr2 As Variant, i As Long, code As String
code = "A**" 'For any order codes containing A11, A12, A13, A21, A22, _
A23, etc
Lastrow = Sheets("SO Hits Data Single Row").Cells(Rows.Count, _
1).End(xlUp).Row
arr1 = Sheets("SO Hits Data Single Row").Range("B4:B" & Lastrow).Value
arr2 = Filter(arr1, code)
Sheets("A##").Range("a1") = arr2
但它只是给出了一个不匹配的错误。
下面是我需要实现的输出示例。
如果你有 Excel 2019 或 Excel 365，那么你可以使用 built-in SORT 和 FILTER 函数来大大简化事情：
Public Function PartsToSheet(OrderPrefix AS String) AS Boolean
PartsToSheet = False
On Error GoTo FuncErr 'Return False if there is an error
Dim calcTMP As xlCalculation
calcTMP = Application.Calculation
'Only Calculate Formulae when we explicitly say to
Application.Calculation = xlCalculationManual
Dim wsSource AS Worksheet, wsDestination AS Worksheet
Dim lParts AS Long, lRecords AS Long
Dim adTable AS String, adOrders AS String
Set wsSource = ThisWorkbook.Worksheets("SO Hits Data Single Row")
Set wsDestination = ThisWorkbook.Worksheets(OrderPrefix & "##")
'Prepare the Destination
With wsDestination
'Deleting Rows & Columns frees up the Used Range, freeing more memory than Clear does
.Range(.Cells(1, 1), .Range(.Rows.Count, 1)).EntireRow.Delete
.Range(.Cells(1, 1), .Range(1, .Columns.Count)).EntireColumn.Delete
End With
lParts = Application.CountA(wsSource.Columns(1))
lRecords = Application.CountIf(wsSource.Columns(2), OrderPrefix & "*")
adTable = wsSource.Range(wsSource.Cells(1, 1),wsSource.Cells(lParts, 2)).Address(True, True, xlA1, True)
adOrders = wsSource.Range(wsSource.Cells(1, 2),wsSource.Cells(lParts, 2)).Address(True, True, xlA1, True)
If lRecords > 0 Then 'If there are Order Codes for this Sheet
wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Formula = _
"=IF(MOD(ROW()+6,8)>0, """", INDEX(SORT(" & _
"FILTER(" & adTable & ", LEFT(" & adOrders & ", 1)=""" & OrderPrefix & """)" & _
", 2), (ROW()+6)/8, 1))"
wsDestination.Columns(1).Calculate 'Explicitly calculate formulae
wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Value = _
wsDestination.Range(wsDestination.Cells(2, 1), wsDestination.Cells(8 * lRecords - 6)).Value
End If
PartsToSheet = True 'Success!
FuncErr:
On Error GoTo -1 'Clear any errors in the handler
Application.Calculation = calcTMP
End Function
基本上，我们用一个将空白 7 行的函数 (IF(MOD(ROW()+6,8)>0,) 填充目标 sheet 的第一列，然后提供下一个条目 (INDEX(.., (ROW()+6)/8, 1))在一个数组中，我们通过 FILTERing 获取前缀，SORTing 获取订单代码。
然后我们通过将结果从动态公式转换为静态值来“扁平化”结果。
因此，我发现数组实际上是解决此问题的最佳方法。但是，文件大小显然是一个主要问题，我发现这是由于当前选择中包含了空白单元格。一旦我更快地修复了宏 运行 但仍然花费了太长时间。我最终编写了代码以将数据保存到一个数组中，然后稍后以类似于以下的方式对其进行过滤。
Sub Example()
Dim arr1 As Variant, arr2(10000) As Variant, i As Long, j As Long, k As Long, Filter As String
Application.ScreenUpdating = False 'Freeze screen while macro runs
Application.EnableEvents = False 'Disable popups
Application.Calculation = xlManual 'Disable Sheet calcs
Filter = "A**"
arr1 = ActiveWorkbook.Worksheets("Sheet1").Range("A4:B12000").Value
j= Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A20000"))
For i = 1 To j
If arr1(i, 2) Like Filter Then
arr2(k) = arr1(i, 1)
arr2(k + 1) = ""
arr2(k + 2) = ""
arr2(k + 3) = ""
arr2(k + 4) = ""
arr2(k + 5) = ""
arr2(k + 6) = ""
arr2(k + 7) = ""
k = k + 8 'This was so I could adjust for the blank spaces I needed between each value in the array
End If
Next i
Application.ScreenUpdating = True 'Unfreeze screen
Application.Calculation = xlAutomatic 'Enable Sheet calcs
Application.EnableEvents = True 'Enable popups
End Sub
上面的代码更适合我的情况，但下面是供以后查看者使用的更通用的形式。
Sub Example()
Dim arr1 As Variant, arr2(10000) As Variant, i As Long, j As Long, k As Long, Filter As String
Application.ScreenUpdating = False 'Freeze screen while macro runs
Application.EnableEvents = False 'Disable popups
Application.Calculation = xlManual 'Disable Sheet calcs
Filter = "A**" 'This is where you would put your filter instead of "A**"
arr1 = ActiveWorkbook.Worksheets("Sheet1").Range("A4:B12000").Value
j= Application.WorksheetFunction.CountA(wb.Sheets("SO Hits Data Single Row").Range("A1:A20000"))
For i = 1 To j
If arr1(i, 2) Like Filter Then
arr2(k) = arr1(i, 1)
End If
Next i
Application.ScreenUpdating = True 'Unfreeze screen
Application.Calculation = xlAutomatic 'Enable Sheet calcs
Application.EnableEvents = True 'Enable popups
End Sub