Optimizing loop for vba macro excel 2007

I have this code that works. it goes down a range and deletes the empty rows, seperates the first character into a different column if its not a number or negative sign.

This code WORKS. but it is too SLOW for the amount of data i need it to deal with. Thank you anyone for your suggestion on how to optimize this code and make it faster.

I have already turned off automatic calculations. screen updating. and visibility of application.

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

There is not so much code that seems to be obviously inefficient.

Here is some tips about what I can tell:

• Don't select cells unless you are really forced too (as it is not within your loop, that is not the worst thing)
• Try to parse range instead of using a Long
• Change your test with a vba statement like IsNumeric
• Use With to avoid calling an object multiple times

Here is a try (i may have changed some behavior because i couldn't understand if you wanted to parse cells or rows):

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

You should process your rows from the bottom to the top: should be faster beacause each delete causes fewer rows to move up.

Untested:

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

This should be pretty speedy. Hope I didn't alter your code too much to change something I shouldn't have.

Grabbing all the data in a variant makes it much faster since the VBA doesn't have to interact with Excel too much. Using special cells also does this. Using "like" cleans the code up, don't know if the performance is any better for that.

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

The following code is untested but should work and go pretty fast. It should be noted that deleted entire rows is fairly costly (time wise) to do, although you can minimize the time using the method below, it will still take a while and there's not much you can do about it:

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