我不是开发人员，但我在这里阅读了一下，以便能够理解其中的一些内容。这可能是我面临的一个简单问题，但我似乎无法弄明白。谢谢你帮我解决这个问题！
我在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 "[A-Z,a-z,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
当我测试~10行时，这整个脚本工作正常。当在整行的220行中使用它时，它变得没有响应并最终崩溃。
在脚本中，我评论了导致此性能问题的原因。我猜这是因为有三个循环。第三个循环遍历字符串中的每个字符以检查它是否是允许的char，然后保留或删除它。
我可以做些什么来提高性能，或者至少可以做到让Excel不会无响应？
旁注：它应该适用于Mac和Mac。视窗。我不知道RegEx是否会有更好的性能来过滤掉不需要的char，但我也不知道是否可以将它用于Mac和Mac。视窗。
答案 0 :(得分：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 '-, :, ., A-Z, a-z, 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
答案 1 :(得分：0)
三件事 - 你需要禁用screenupdating，你需要以更好的方式声明变量。不要像＆＃34; Dim a，b，c，d，e作为整数＆＃34;，因为只有最后一个是整数，其他是变体。最后但同样重要的是，不要在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 "[A-Z,a-z,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
答案 2 :(得分：0)
任务列表
Sub MagicButton_Click2()
Dim 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
For i = 1 To UBound(arData)
arData(i, 1) = AlphaNumericOnly(CStr(arData(i, 1)))
Next
dataRange.value = arData
dataRange.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="{", TrailingMinusNumbers:=True
End Sub
' http://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp
Function AlphaNumericOnly(strSource As String) As String
Dim i As Integer
Dim strResult As String
For i = 1 To Len(strSource)
Select Case Asc(Mid(strSource, i, 1))
Case 48 To 57, 65 To 90, 97 To 123: 'include 32 if you want to include space I added 123 to include the {
strResult = strResult & Mid(strSource, i, 1)
End Select
Next
AlphaNumericOnly = strResult
End Function