如果在大型数据集上使用Excel VBA循环执行速度非常慢，然后崩溃

我不是一名开发人员，但我在这里和那里读了一些能够理解它的一些。 这可能是我面对的一个简单的问题，但我似乎无法弄清楚。 所以谢谢你帮助我！

我在Google的帮助下写了一个简短的脚本，该脚本可以将CSV导出转换为可读格式。 它应该做更多的事情，但我已经面临性能问题，只是为了使一些条目可读。

以下是我到目前为止：

Sub MagicButton_Click() 'Find the last non-empty cell in column A Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row 'Set Variables to work with the cell content Dim CellContent As String Dim CellContentArr As Variant 'Set looping variables Dim i, j As Integer Dim FirstRow As Integer Dim FirstCol As Integer Dim ActiveCol As Integer Dim itm As Variant FirstRow = 1 FirstCol = 2 Dim x, y As String 'Loop (1) through all rows For i = FirstRow To LastRow 'Save cell content to string CellContent = ActiveSheet.Cells(i, 1).Text 'Split string into array CellContentArr = Split(CellContent, "{") 'Reset column ActiveCol = FirstCol 'Loop (2) through the array For Each itm In CellContentArr 'Remove quotations and other symbols itm = Application.WorksheetFunction.Clean(itm) itm = Replace(itm, """", "") 'This is the part that creates performance issues 'For j = 1 To Len(itm) ' x = Mid(itm, j, 1) ' If x Like "[AZ,az,0-9 :.-]" Then ' y = y & x ' End If 'Next j 'itm = y 'y = "" 'Write each item in array to an individual cells within the same row ActiveSheet.Cells(i, ActiveCol) = itm ActiveCol = ActiveCol + 1 Next itm Next i End Sub 

当我testing~10行时，整个脚本工作正常。 当在整个220行上使用它时，它变得没有反应并最终崩溃。

在脚本中，我评论了导致此性能问题的原因。 我猜这是因为有三个循环。 第三个循环遍历string中的每个字符，以检查它是否为允许的字符，然后保留或删除它。

我可以做些什么来提高性能，或者至less使Excel能够不响应？

旁注：它应该在Mac和Windows上都可以工作。 我不知道如果正则expression式会有更好的性能来过滤不需要的字符，但我也不知道是否有可能用于Mac和Windows。

Answer 1

三件事 – 你需要禁用screenupdating，你需要更好地声明variables。 不要像“Dim a，b，c，d，e as Integer”那样做，因为只有最后一个是整数，其他的是不同的。 最后但并非最不重要，不要在VBA中使用Integer，但这不是你的问题。

这应该工作得更快：

 Sub MagicButton_Click() 'Find the last non-empty cell in column A Dim LastRow As Long LastRow = Range("A" & Rows.Count).End(xlUp).Row 'Set Variables to work with the cell content Dim CellContent As String Dim CellContentArr As Variant 'Set looping variables Dim i As Long dim j as Long Dim FirstRow As Long Dim FirstCol As Long Dim ActiveCol As Long Dim itm As Variant FirstRow = 1 FirstCol = 2 Dim x as string dim y As String call onstart 'Loop (1) through all rows For i = FirstRow To LastRow 'Save cell content to string CellContent = ActiveSheet.Cells(i, 1).Text 'Split string into array CellContentArr = Split(CellContent, "{") 'Reset column ActiveCol = FirstCol 'Loop (2) through the array For Each itm In CellContentArr 'Remove quotations and other symbols itm = Application.WorksheetFunction.Clean(itm) itm = Replace(itm, """", "") 'This is the part that creates performance issues 'For j = 1 To Len(itm) ' x = Mid(itm, j, 1) ' If x Like "[AZ,az,0-9 :.-]" Then ' y = y & x ' End If 'Next j 'itm = y 'y = "" 'Write each item in array to an individual cells within the same row ActiveSheet.Cells(i, ActiveCol) = itm ActiveCol = ActiveCol + 1 Next itm Next i call onend End Sub Public Sub OnStart() Application.AskToUpdateLinks = False Application.ScreenUpdating = False Application.Calculation = xlAutomatic Application.EnableEvents = False Application.DisplayAlerts = False End Sub Public Sub OnEnd() Application.DisplayAlerts = True Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False Application.AskToUpdateLinks = True End Sub 

Answer 2

已经给出的答案将是你的代码的很好的调整。 但是，这可能有更好的方法。

首先，将一个范围读入一个数组并操作所产生的数组显然比逐个读取更快。

其次，如果你正在迭代你的数组中的每个字符，并用一个大括号指定一个新列来检查特定项目，那么你能不能在一次迭代中完成这一切。 先拆分和清理似乎有点多余。

总而言之，你的代码可以像这样简单：

 Dim lastCell As Range Dim v As Variant Dim r As Long Dim c As Long Dim i As Integer Dim output() As String Dim b() As Byte 'Read the values into an array With ThisWorkbook.Worksheets("Sheet1") Set lastCell = .Cells(.Rows.Count, "A").End(xlUp) v = .Range(.Cells(1, "A"), lastCell).Value2 End With ReDim output(1 To UBound(v, 1), 1 To 1) 'Loop through the array rows and characters For r = 1 To UBound(v, 1) c = 1 'Convert item to byte array - just personal preference, you could iterate a string b = StrConv(v(r, 1), vbFromUnicode) For i = 0 To UBound(b) Select Case b(i) Case 45, 46, 58, 65 To 90, 97 To 122, 48 To 57 '-, :, ., AZ, az, 0-9 output(r, c) = output(r, c) & Chr(b(i)) Case 123 '{ 'add a column and expand output array if necessary If Len(output(r, c)) > 0 Then c = c + 1 If c > UBound(output, 2) Then ReDim Preserve output(1 To UBound(v, 1), 1 To c) End If End If Case Else 'skip it End Select Next Next 'Write item to worksheet ThisWorkbook.Worksheets("Sheet1").Cells(1, "B") _ .Resize(UBound(output, 1), UBound(output, 2)).Value = output 

Answer 3

任务列表

• 将源范围复制到数组中
• 清洁arrays
• 将数组复制回源范围
• 使用TextToColumns将数据拆分成多个列

 Sub MagicButton_Click2（）
    昏暗arData
     Dim LastRow As Long，i As Integer
     Dim dataRange As Range
     LastRow = Range（“A”＆rowS.Count）.End（xlUp）.Row

     Set dataRange = Range（Cells（1,1），Cells（LastRow，1））
     arData = dataRange.value


    对于i = 1到UBound（arData）
         arData（i，1）= AlphaNumericOnly（CStr（arData（i，1）））
    下一个

     dataRange.value = arData
     dataRange.TextToColumns目标：=范围（“A1”），数据types：= xlDelimited，_
         TextQualifier：= xlDoubleQuote，ConsecutiveDelimiter：= False，Tab：= True，_
        分号：= False，逗号：= False，空格：= False，其他：= True，OtherChar _
         ：=“{”，TrailingMinusNumbers：= True
结束小组

 'http://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
函数AlphaNumericOnly（strSource作为string）作为string
    昏暗我作为整数
     Dim strResult As String

    对于i = 1到Len（strSource）
        selectCase Asc（Mid（strSource，i，1））
            情况48到57，65到90,97到123：“包括32，如果你想包括空间，我加123包括{
                 strResult = strResult＆Mid（strSource，i，1）
        结束select
    下一个
     AlphaNumericOnly = strResult
结束function