VBA - 如何加快过滤过程
VBA - How to speed up the filter process
现在正在做一个数据量非常大的项目(70万行*27列)。我现在面临的问题如下:
数据示例:
Date Category1 P&L ........ (other columns)
20180901 XXCV 123,542
20180901 ASB 4523,542
20180901 XXCV 12243,544
20180901 XXCV 12334,542
20180901 DEE 14623,5441
.
.
.
现在我有一个新类别名称列表,我必须用新名称替换旧名称。该列表如下所示:
Old_name New_Name
XXCV XASS
ASB CSS
.
.
.
我解决这个问题的方法是循环遍历列表中的所有旧名称,然后对原始数据中的每个名称进行过滤,最后将旧名称更改为新名称。
例如:
第一个循环是 XXCV。宏转到原始数据 sheet 并通过 XXCV 过滤列 "Catagory1"。然后将所有 XXCV 更改为 XASS。
宏 继续这样做,直到它循环遍历所有旧名称。
问题是!数据太多了!过滤过程很慢。
另外,我有2000个旧名字需要改成新名字。也就是说,我要循环2000次!
我花了很多时间才完成整个过程。
我知道在 Access 中执行此任务可能会更好。但是,是否有可能加快此过程并使其在 5-10 分钟内完成?
提前致谢!
编辑:
代码如下:
Sub Mapping_Table()
Dim row_ori_book As Long
Dim row_fin_book As Long
Dim original_book As Variant
Dim sheets_name As Variant
Dim n_sheetName As Variant
Dim row_end As Long
Dim col_end As Long
Dim row_loop As Long
Dim n_ori_book As Variant
' Modify book name in sheet CoC_Exp_NExp & sheet CoC UU
Sheets("Mapping_Table").Activate
row_ori_book = Cells(Rows.Count, "A").End(xlUp).Row
'row_fin_book = Cells(Rows.Count, "B").End(xlUp).Row
original_book = Range(Cells(2, "A"), Cells(row_ori_book, "A")).Value
sheets_name = Array("CoC_Exp_NExp", "CoC_UU")
For Each n_sheetName In sheets_name
Sheets(n_sheetName).Activate
row_end = Cells(Rows.Count, "A").End(xlUp).Row
col_end = Cells(1, Columns.Count).End(xlToLeft).Column
row_loop = 2
For Each n_ori_book In original_book
ActiveSheet.AutoFilterMode = False
Range(Cells(1, 1), Cells(row_end, col_end)).AutoFilter Field:=12, Criteria1:=n_ori_book, Operator:=xlFilterValues
On Error Resume Next
Range(Cells(2, "L"), Cells(row_end, "L")).SpecialCells(xlCellTypeVisible).Value = Sheets("Mapping_Table").Cells(row_loop, "B").Value
On Error GoTo 0
row_loop = row_loop + 1
ActiveSheet.AutoFilterMode = False
Next n_ori_book
Next
End Sub
这样做速度很快,但略有不同。它将查找并替换 每个 在 sheet 中出现的旧名称,而不仅仅是列 L。如果有其他列包含旧值并且您不想要那些被替换的,我们可能不得不尝试别的东西。
这利用了 cybernetic.nomad 建议的内置查找和替换功能。它仅扫描重新映射 table 中的行而不是目标 sheets.
中的所有行
Sub Mapping_Table()
Dim mapTable As Range ' Column A (old name) maps to Column B (new name)
Dim mapRow As Integer ' Index for walking through map table
Dim sheetNames As Variant ' Array of sheet names to update
Dim sheetName As Variant ' Sheet name being processed
' Get the map table
Set mapTable = Sheets("Mapping_Table").UsedRange
' Set the list of sheets to process
sheetNames = Array("CoC_Exp_NExp", "CoC_UU")
' Search and replace
For Each sheetName In sheetNames
For mapRow = 1 To mapTable.Rows.Count
Sheets(sheetName).Cells.Replace What:=mapTable.Cells(mapRow, 1).Text, _
Replacement:=mapTable.Cells(mapRow, 2).Text, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Next
Next
End Sub
现在正在做一个数据量非常大的项目(70万行*27列)。我现在面临的问题如下:
数据示例:
Date Category1 P&L ........ (other columns)
20180901 XXCV 123,542
20180901 ASB 4523,542
20180901 XXCV 12243,544
20180901 XXCV 12334,542
20180901 DEE 14623,5441
.
.
.
现在我有一个新类别名称列表,我必须用新名称替换旧名称。该列表如下所示:
Old_name New_Name
XXCV XASS
ASB CSS
.
.
.
我解决这个问题的方法是循环遍历列表中的所有旧名称,然后对原始数据中的每个名称进行过滤,最后将旧名称更改为新名称。
例如: 第一个循环是 XXCV。宏转到原始数据 sheet 并通过 XXCV 过滤列 "Catagory1"。然后将所有 XXCV 更改为 XASS。 宏 继续这样做,直到它循环遍历所有旧名称。
问题是!数据太多了!过滤过程很慢。
另外,我有2000个旧名字需要改成新名字。也就是说,我要循环2000次! 我花了很多时间才完成整个过程。
我知道在 Access 中执行此任务可能会更好。但是,是否有可能加快此过程并使其在 5-10 分钟内完成?
提前致谢!
编辑: 代码如下:
Sub Mapping_Table()
Dim row_ori_book As Long
Dim row_fin_book As Long
Dim original_book As Variant
Dim sheets_name As Variant
Dim n_sheetName As Variant
Dim row_end As Long
Dim col_end As Long
Dim row_loop As Long
Dim n_ori_book As Variant
' Modify book name in sheet CoC_Exp_NExp & sheet CoC UU
Sheets("Mapping_Table").Activate
row_ori_book = Cells(Rows.Count, "A").End(xlUp).Row
'row_fin_book = Cells(Rows.Count, "B").End(xlUp).Row
original_book = Range(Cells(2, "A"), Cells(row_ori_book, "A")).Value
sheets_name = Array("CoC_Exp_NExp", "CoC_UU")
For Each n_sheetName In sheets_name
Sheets(n_sheetName).Activate
row_end = Cells(Rows.Count, "A").End(xlUp).Row
col_end = Cells(1, Columns.Count).End(xlToLeft).Column
row_loop = 2
For Each n_ori_book In original_book
ActiveSheet.AutoFilterMode = False
Range(Cells(1, 1), Cells(row_end, col_end)).AutoFilter Field:=12, Criteria1:=n_ori_book, Operator:=xlFilterValues
On Error Resume Next
Range(Cells(2, "L"), Cells(row_end, "L")).SpecialCells(xlCellTypeVisible).Value = Sheets("Mapping_Table").Cells(row_loop, "B").Value
On Error GoTo 0
row_loop = row_loop + 1
ActiveSheet.AutoFilterMode = False
Next n_ori_book
Next
End Sub
这样做速度很快,但略有不同。它将查找并替换 每个 在 sheet 中出现的旧名称,而不仅仅是列 L。如果有其他列包含旧值并且您不想要那些被替换的,我们可能不得不尝试别的东西。
这利用了 cybernetic.nomad 建议的内置查找和替换功能。它仅扫描重新映射 table 中的行而不是目标 sheets.
中的所有行Sub Mapping_Table()
Dim mapTable As Range ' Column A (old name) maps to Column B (new name)
Dim mapRow As Integer ' Index for walking through map table
Dim sheetNames As Variant ' Array of sheet names to update
Dim sheetName As Variant ' Sheet name being processed
' Get the map table
Set mapTable = Sheets("Mapping_Table").UsedRange
' Set the list of sheets to process
sheetNames = Array("CoC_Exp_NExp", "CoC_UU")
' Search and replace
For Each sheetName In sheetNames
For mapRow = 1 To mapTable.Rows.Count
Sheets(sheetName).Cells.Replace What:=mapTable.Cells(mapRow, 1).Text, _
Replacement:=mapTable.Cells(mapRow, 2).Text, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
Next
Next
End Sub