Excel 性能问题-根据列标题重新排列列
我有一个Excel工作簿，有数百列要重新排列。尝试了不同的方法重新排列这些列后，我开发了自己的解决方案，因为它比我在这里和其他地方找到的更快： 我的代码： 我基本上是在标题行中搜索某个字符串，然后将该列复制到临时/辅助表中，完成后搜索下一个术语，依此类推，直到搜索到所有类别。之后，我以正确的顺序将块复制回主工作表 编辑：保持每一列的格式至关重要，因此将所有内容放入一个数组不起作用，因为格式信息将消失Excel 性能问题-根据列标题重新排列列,excel,vba,Excel,Vba,我有一个Excel工作簿，有数百列要重新排列。尝试了不同的方法重新排列这些列后，我开发了自己的解决方案，因为它比我在这里和其他地方找到的更快： 我的代码： 我基本上是在标题行中搜索某个字符串，然后将该列复制到临时/辅助表中，完成后搜索下一个术语，依此类推，直到搜索到所有类别。之后，我以正确的顺序将块复制回主工作表 编辑：保持每一列的格式至关重要，因此将所有内容放入一个数组不起作用，因为格式信息将消失 Sub cutColumnsToTempAndMoveBackSorted() Appl
Sub cutColumnsToTempAndMoveBackSorted()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Call declareVariables
iCountCompanies = lngLastCol - iColStart + 1
' Timer
Dim StartTime As Double
Dim SecondsElapsed As Double
' Remember time when macro starts
StartTime = Timer
iStartColTemp = 0
wsTempCompanies.UsedRange.Delete
' First copy all columns with "ABC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "ABC" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "DDD"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "DDD" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "CCC"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "CCC" Or ws.Cells(iRowCategory, i) = "" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
' Then copy all columns with "EEE"
For i = iColStart To lngLastCol
If ws.Cells(iRowCategory, i) = "EEE" Then
iStartColTemp = iStartColTemp + 1
ws.Columns(i).Copy
wsTempCompanies.Columns(iStartColTemp).Insert
End If
Next i
Dim iLastColTemp As Integer: iLastColTemp = iStartColTemp
iStartColTemp = 1
ws.Range(Col_Letter(iColStart) & ":" & Col_Letter(lngLastCol)).Delete 'Col_Letter function gives back the column ist characters instead of column ID
' Move back to Main Sheet
wsTempCompanies.Range(Col_Letter(iStartColTemp) & ":" & Col_Letter(iLastColTemp)).Copy
ws.Range(Col_Letter(iColStart + 1) & ":" & Col_Letter(lngLastCol + 1)).Insert
ws.Columns(iColStart).Delete
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
Debug.Print "Time: " & SecondsElapsed & " Sekunden."
ende:
Application.ScreenUpdating = True
Call activateApplication ' All kinds of screenupdates, such as enableevents, calculations, ...
End Sub
如果出于某种原因，您不允许从ws中剪切元素，那么创建该工作的临时副本可能是个好主意。以下是我对解决方案的看法。它与@BruceWayne在您的第一个链接中的链接非常相似，只是它将直接转到正确的列，而不是检查每个列 此时，代码会查找部分匹配项，因此ABC和DEF都会找到ABCDEF。在FIND命令中将xlPart更改为xlother，使其与确切的标题匹配
Sub Test()
Dim CorrectOrder() As Variant
Dim OrderItem As Variant
Dim FoundItem As Range
Dim FirstAddress As String
Dim NewOrder As Collection
Dim LastColumn As Range
Dim NewPosition As Long
Dim tmpsht As Worksheet
CorrectOrder = Array("ABC", "DEF", "GHI", "JKL")
With ThisWorkbook.Worksheets("Sheet1")
Set LastColumn = .Cells(2, .Columns.Count).End(xlToLeft) 'Return a reference to last column on row 2.
Set NewOrder = New Collection
With .Range(.Cells(2, 1), LastColumn) 'Refer to the range A2:LastColumn.
'Search for each occurrence of each value and add the column number to a collection in the order found.
For Each OrderItem In CorrectOrder
Set FoundItem = .Find(What:=OrderItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not FoundItem Is Nothing Then
FirstAddress = FoundItem.Address
Do
NewOrder.Add FoundItem.Column
Set FoundItem = .FindNext(FoundItem)
Loop While FoundItem.Address <> FirstAddress
End If
Next OrderItem
End With
End With
'Providing some columns have been found then move them in order to a temporary sheet.
If NewOrder.Count > 1 Then
NewPosition = 2
Set tmpsht = ThisWorkbook.Worksheets.Add
For Each OrderItem In NewOrder
ThisWorkbook.Worksheets("Sheet1").Columns(OrderItem).Cut _
tmpsht.Columns(NewPosition)
NewPosition = NewPosition + 1
Next OrderItem
'Copy the reordered columns back to the original sheet.
tmpsht.Columns(2).Resize(, NewOrder.Count).Cut _
ThisWorkbook.Worksheets("Sheet1").Columns(2)
'Delete the temp sheet.
Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True
End If
End Sub
以下是我对解决方案的看法。它与@BruceWayne在您的第一个链接中的链接非常相似，只是它将直接转到正确的列，而不是检查每个列 此时，代码会查找部分匹配项，因此ABC和DEF都会找到ABCDEF。在FIND命令中将xlPart更改为xlother，使其与确切的标题匹配
Sub Test()
Dim CorrectOrder() As Variant
Dim OrderItem As Variant
Dim FoundItem As Range
Dim FirstAddress As String
Dim NewOrder As Collection
Dim LastColumn As Range
Dim NewPosition As Long
Dim tmpsht As Worksheet
CorrectOrder = Array("ABC", "DEF", "GHI", "JKL")
With ThisWorkbook.Worksheets("Sheet1")
Set LastColumn = .Cells(2, .Columns.Count).End(xlToLeft) 'Return a reference to last column on row 2.
Set NewOrder = New Collection
With .Range(.Cells(2, 1), LastColumn) 'Refer to the range A2:LastColumn.
'Search for each occurrence of each value and add the column number to a collection in the order found.
For Each OrderItem In CorrectOrder
Set FoundItem = .Find(What:=OrderItem, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart)
If Not FoundItem Is Nothing Then
FirstAddress = FoundItem.Address
Do
NewOrder.Add FoundItem.Column
Set FoundItem = .FindNext(FoundItem)
Loop While FoundItem.Address <> FirstAddress
End If
Next OrderItem
End With
End With
'Providing some columns have been found then move them in order to a temporary sheet.
If NewOrder.Count > 1 Then
NewPosition = 2
Set tmpsht = ThisWorkbook.Worksheets.Add
For Each OrderItem In NewOrder
ThisWorkbook.Worksheets("Sheet1").Columns(OrderItem).Cut _
tmpsht.Columns(NewPosition)
NewPosition = NewPosition + 1
Next OrderItem
'Copy the reordered columns back to the original sheet.
tmpsht.Columns(2).Resize(, NewOrder.Count).Cut _
ThisWorkbook.Worksheets("Sheet1").Columns(2)
'Delete the temp sheet.
Application.DisplayAlerts = False
tmpsht.Delete
Application.DisplayAlerts = True
End If
End Sub
如果不是太多的努力，下面的内容可能会有所帮助 一张表中的示例数据集我们将其称为主表 第2行示例标题行包括查找关键字-ABC、DDD、CCC、EEE 第1行：用于显示表头订单号的临时行 参考表，该表按所需的从左到右排序顺序列出查找关键字 回到主工作表，我们想在第1行生成序列号。 如第1张图像中突出显示的，可以使用单元格A1中的以下匹配公式进行匹配
=MATCH(TRUE,ISNUMBER(SEARCH(References!$A$2:$A$5,A2)),0)
附言：虽然我还没有计算出这种方法在大型数据集上的性能，但我相信它会相当快。如果不太费劲的话，下面的内容可能会有所帮助 一张表中的示例数据集我们将其称为主表 第2行示例标题行包括查找关键字-ABC、DDD、CCC、EEE 第1行：用于显示表头订单号的临时行 参考表，该表按所需的从左到右排序顺序列出查找关键字 回到主工作表，我们想在第1行生成序列号。 如第1张图像中突出显示的，可以使用单元格A1中的以下匹配公式进行匹配
=MATCH(TRUE,ISNUMBER(SEARCH(References!$A$2:$A$5,A2)),0)
注：虽然我还没有计算出这种方法在大数据集上的性能，但我相信它会相当快。请测试下一个代码。大部分功劳必须归功于@Karthick Ganesan的创意。代码仅将他的想法放在VBA中：
Sub reorderColumnsByRanking()
Dim sh As Worksheet, arrOrd As Variant, lastCol As Long, i As Long
Dim El As Variant, boolFound As Boolean, isF As Long
Set sh = ActiveSheet 'use here your necessary sheet
lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
arrOrd = Split("ABC|1,DDD|2,CCC|3,EEE|4", ",") 'load criteria and their rank
'insert a helping row____________________
sh.Range("A1").EntireRow.Insert xlAbove
'________________________________________
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Rank the columns_______________________________________________________________
For i = 1 To lastCol
For Each El In arrOrd
If IsFound(sh.Cells(2, i), CStr(Split(El, "|")(0))) Then
sh.Cells(1, i).Value = Split(El, "|")(1): boolFound = True: Exit For
End If
Next
If Not boolFound Then sh.Cells(1, i).Value = 16000
boolFound = False
Next i
'_______________________________________________________________________________
'Sort LeftToRight_____________________________________________________________
sh.Sort.SortFields.Add2 key:=sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
.SetRange sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
'____________________________________________________________________________
'Delete helping first row____
sh.Rows(1).Delete xlDown
'____________________________
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
Private Function IsFound(rng As Range, strS As String) As Boolean
Dim fC As Range
Set fC = rng.Find(strS)
If Not fC Is Nothing Then
IsFound = True
Else
IsFound = False
End If
End Function
请测试下一个代码。大部分功劳必须归功于@Karthick Ganesan的创意。代码仅将他的想法放在VBA中：
Sub reorderColumnsByRanking()
Dim sh As Worksheet, arrOrd As Variant, lastCol As Long, i As Long
Dim El As Variant, boolFound As Boolean, isF As Long
Set sh = ActiveSheet 'use here your necessary sheet
lastCol = sh.Cells(1, Columns.Count).End(xlToLeft).Column
arrOrd = Split("ABC|1,DDD|2,CCC|3,EEE|4", ",") 'load criteria and their rank
'insert a helping row____________________
sh.Range("A1").EntireRow.Insert xlAbove
'________________________________________
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Rank the columns_______________________________________________________________
For i = 1 To lastCol
For Each El In arrOrd
If IsFound(sh.Cells(2, i), CStr(Split(El, "|")(0))) Then
sh.Cells(1, i).Value = Split(El, "|")(1): boolFound = True: Exit For
End If
Next
If Not boolFound Then sh.Cells(1, i).Value = 16000
boolFound = False
Next i
'_______________________________________________________________________________
'Sort LeftToRight_____________________________________________________________
sh.Sort.SortFields.Add2 key:=sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With sh.Sort
.SetRange sh.Range(sh.Cells(1, 1), sh.Cells(1, lastCol)).EntireColumn
.Header = xlYes
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
'____________________________________________________________________________
'Delete helping first row____
sh.Rows(1).Delete xlDown
'____________________________
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationManual
End Sub
Private Function IsFound(rng As Range, strS As String) As Boolean
Dim fC As Range
Set fC = rng.Find(strS)
If Not fC Is Nothing Then
IsFound = True
Else
IsFound = False
End If
End Function
使用内存中的对象[][]执行此操作。我应该提到，我将编辑我的帖子，保持这些列中每个单元格的格式至关重要，因为值是彩色的，字体是不同的。这是一个要点，这意味着你不能将原始内存用于基本类型，你必须使用对象模型。。。除非你真的准备好收集每种细胞类型的信息，否则我在这里做的恰恰相反——投入硬件并在SSD更高的CPU上运行可能是成本更低的解决方案。<5小时的工作。这就是我的观点，如果你想这么快就应该避免对象模型。如果你需要单元格样式，那么你必须创造性地获取带有样式信息的数据。这是更快地转换此数据的唯一方法-使用值的二维对象数组和样式的另一个二维对象数组，然后您可以立即在内存中重新定义保留和交换列，然后将数据渲染回电子表格。@smartini，作为一种脱离VBA的解决方案，如果您在单独的工作表上有已排序的列标题，您可以在标题行上方创建临时行，并使用匹配公式获取每个列标题上方的订单号。然后，您可以在此临时编号行上从左到右排序，以使列在格式不变的情况下重新排列。使用内存中的对象[][]执行此操作。我应该提到，我将编辑我的帖子，保持这些列中每个单元格的格式至关重要，因为值是彩色的，字体是不同的。这是一个要点，这意味着你不能将原始内存用于基本类型，你必须使用对象模型。。。除非你真的准备好收集每种细胞类型的信息，否则我在这里做的恰恰相反——投入硬件并在SSD更高的CPU上运行可能是成本更低的解决方案。<5小时的工作。这就是我的观点，如果你想这么快就应该避免对象模型。如果你需要单元格样式，那么你必须创造性地获取带有样式信息的数据。这是更快地转换此数据的唯一方法-使用值的二维对象数组和样式的另一个二维对象数组，然后您可以立即在内存中重新定义保留和交换列，然后将数据渲染回电子表格。@smartini，作为一种脱离VBA的解决方案，如果您在单独的工作表上有已排序的列标题，您可以在标题行上方创建临时行，并使用匹配公式获取每个列标题上方的订单号。然后，您可以在此临时编号行上从左到右排序，以使列重新排列，格式保持不变。直接将值从Range1设置为Range2而无需复制会更快。无剪切/复制/粘贴。我想OP正在寻找像这样的超快速的东西，你抓取2D数组中的数据，交换列，或者在这种情况下交换行：我不知道为什么，但它比仅仅复制要花3倍的时间。也许这与我在工作表中的自定义项有关？事实上，它们不应该被触发，因为我在一开始的代码中就阻止了这一点。直接将值从Range1设置为Range2而不进行复制会更快。无剪切/复制/粘贴。我想OP正在寻找像这样的超快速的东西，你抓取2D数组中的数据，交换列，或者在这种情况下交换行：我不知道为什么，但它比仅仅复制要花3倍的时间。也许这与我在工作表中的自定义项有关？事实上，他们不应该被解雇，因为我在一开始的代码中阻止了这一点。谢谢！你的代码比我现在的方法快了50%。如果我的工作簿中有更多的列，速度可能会成倍提高。谢谢！你的代码比我现在的方法快了50%。如果我的工作簿中有更多的列，速度可能会更快。哇，这是一个极好的解决方案！它与我的示例矩阵一起工作，我将尝试在VBA中实现特定的排序函数，以便在需要时启动它。这太棒了！这就是我在问题评论中暗示的解决方案。。。干杯：哇，
这是一个极好的解决方案！它与我的示例矩阵一起工作，我将尝试在VBA中实现特定的排序函数，以便在需要时启动它。这太棒了！这就是我在问题评论中暗示的解决方案。。。干杯：谢谢你的贡献。我尝试过这种方法，这确实是最快的解决方案——多么令人兴奋的表现啊！谢谢大家。该工具的许多用户在使用后都遇到了问题。我花了好几个小时才把它固定在根上。排序完成后，添加以下代码非常重要！sh.Sort.SortFields.Clear否则文件将损坏，并且当再次启动工作簿时，将提示用户修复选项。更多细节可以在这个线程中找到，在这里我找到了用户@Yoni:@smartini解决问题的方法：你应该谈谈这个问题。。。我知道在一些安装的情况下会有这种解决方法。当然，我测试了上面的代码，在我的安装中，工作簿没有发生任何错误。我想你也有一个稳定的版本。您使用什么Office版本？谢谢您的贡献。我尝试过这种方法，这确实是最快的解决方案——多么令人兴奋的表现啊！谢谢大家。该工具的许多用户在使用后都遇到了问题。我花了好几个小时才把它固定在根上。排序完成后，添加以下代码非常重要！sh.Sort.SortFields.Clear否则文件将损坏，并且当再次启动工作簿时，将提示用户修复选项。更多细节可以在这个线程中找到，在这里我找到了用户@Yoni:@smartini解决问题的方法：你应该谈谈这个问题。。。我知道在一些安装的情况下会有这种解决方法。当然，我测试了上面的代码，在我的安装中，工作簿没有发生任何错误。我想你也有一个稳定的版本。你使用什么Office版本？