Question

我有这个代码可行。它向下移动一个范围并删除空行，如果它不是数字或负号，则将第一个字符分隔成不同的列。
这段代码工作。但是对于我需要它处理的数据量来说太慢了。感谢任何人提出有关如何优化此代码并使其更快的建议。

我已经关闭了自动计算功能。屏幕更新。和应用的可见性。

Dim rng As Range
Dim i As Long
Dim Tracking As Long

Dim textval As String
Dim limitz As String
Dim remaining As String

Range("B1").End(xlDown).Offset(0, 5).Select

Set rng = Range("G2", ActiveCell).Select

i = 1
Range("G2").Select

For Tracking = 1 To rng.Rows.Count

    textval = rng.Cells(i).Value
    limitz = Left(textval, 1)

    If limitz = "" Then
      rng.Cells(i).EntireRow.Delete
     ElseIf limitz <> "0" And limitz <> "1" And limitz <> "2" And limitz <> "3" And limitz <> "4" And limitz <> "5" And limitz <> "6" And limitz <> "7" And limitz <> "8" And limitz <> "9" And limitz <> "-" Then
      remaining = Right(textval, Len(textval) - 1)
      rng.Cells(i) = remaining
      rng.Cells(i).Offset(0, 1).Value = limitz
      i = i + 1
     Else
      i = i + 1
    End If

Next

Answer 1

没有那么多代码似乎明显效率低下。

以下是一些关于我能说的内容的提示：

不要选择单元格除非你真的被迫（因为它不在你的循环中，这不是最糟糕的事情）
尝试解析range而不是使用 Long
使用IsNumeric
使用With避免多次调用对象

这是一个尝试（我可能已经改变了一些行为，因为我无法理解你是否要解析单元格或行）：

Sub test()
  Dim rng As Range, row As Range
  Dim i As Long

  Dim textval As String
  Dim limitz As String
  Dim remaining As String

  Set rng = Range("G2", Range("B1").End(xlDown).Offset(0, 5))
  i = 1

  For Each row In rng.Rows
      With row
        textval = .Cells(i).Value
        limitz = Left(textval, 1)

        If limitz = "" Then
            .Cells(i).EntireRow.Delete
        ElseIf limitz <> "-" And Not IsNumeric(limitz) Then
          remaining = Right(textval, Len(textval) - 1)
          With .Cells(i)
            .Value = remaining
            .Offset(0, 1).Value = limitz
          End With
          i = i + 1
         Else
          i = i + 1
        End If
      End With
  Next
End Sub

Answer 2

您应该从底部到顶部处理您的行：应该更快，因为每次删除都会导致更少的行向上移动。

未测试：

Sub test()

    Dim rng As Range, c As Range
    Dim numRows As Long
    Dim Tracking As Long

    Dim textval As String
    Dim limitz As String

    Set rng = Range("G2", Range("B1").End(xlDown).Offset(0, 5))
    numRows = rng.Rows.Count

    For Tracking = numRows To 1 Step -1

        Set c = rng.Cells(Tracking)
        textval = c.Value
        limitz = Left(textval, 1)

        If limitz = "" Then
          c.EntireRow.Delete
        ElseIf Not limitz Like "[0-9-]" Then
          c.Value = Right(textval, Len(textval) - 1)
          c.Offset(0, 1).Value = limitz
        End If

    Next

End Sub

Answer 3

这应该非常快。希望我没有太多改变你的代码来改变我不应该拥有的东西。

抓取变体中的所有数据会使速度更快，因为VBA不必过多地与Excel交互。使用特殊单元格也可以。使用“like”清除代码，不知道性能是否更好。

Dim rng As Range
Dim vData As Variant
Dim i As Long
Dim limitz As String

Set rng = Range("G2", Range("B1").End(xlDown).Offset(0, 5).Address)

'Delete empty cells
On Error Resume Next
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

'Get all data in range
vData = rng.Resize(, 2)

For i = 1 To UBound(vData)

    limitz = Left$(CStr(vData(i, 1)), 1)

    If limitz Like "[!0-9,!-]" Then
      vData(i, 1) = Right$(CStr(vData(i, 1)), Len(vData(i, 1)) - 1)
      vData(i, 2) = limitz
    End If
Next

rng.Resize(, 2) = vData

以下代码未经测试但应该可以正常运行。应该注意的是，删除整行是相当昂贵的（时间明智），虽然你可以使用下面的方法最小化时间，但它仍然需要一段时间，你可以做的不多：

dim bUnion as boolean
Dim rng As Range, rUnion as range
Dim vData As Variant
Dim i As Long
Dim limitz As String

Set rng = Range("G2", Range("B1").End(xlDown).Offset(0, 5).Address)

'Get all data in range
vData = rng.Resize(, 2)

bunion=false
For i = 1 To UBound(vData)

    if len(vdata(i,1))>0 THEN
      limitz = Left$(CStr(vData(i, 1)), 1)

      If limitz Like "[!0-9,!-]" Then
        vData(i, 1) = Right$(CStr(vData(i, 1)), Len(vData(i, 1)) - 1)
        vData(i, 2) = limitz
      End If
    else
      if bunion then 
          set runion=union(runion,range("A" & i+1))
      else
          set runion=range("A" & i+1)
          bunion=true
      end if
    end if
Next

rng.Resize(, 2) = vData
runion.entirerow.delete

优化vba宏excel 2007的循环

3 个答案: