Dodgy array and loop - this might be very bad...

[Alex Wren]

Hello forum goers,

I have created a working bit of VBA for excel.

Just in case it is not obvious - here is my mission

1 - Replace contents of three particular cells in a table row with corrected values from the array

2 - Use a second loop to repeat the whole process again on a pre-counted number of rows from a different sheet (see numrows)

Anyway have used screen updating to speed it up a little but it still takes a good 5 minutes to run 1500 rows.

Help - it needs to be a little faster than this.

Alex


[vba]Dim numrows As Integer

Sheets("in").Activate
numrows = Application.CountA(Sheets("in").Range("C1:C10000"), "")

' Less dodgy array for non HTML character replacement

Dim lCount As Long, lNum As Long
Dim Rowcounter As Long
Dim Arr(2, 57)

Arr(1, 1) = Chr(32)
Arr(1, 2) = Chr(33)
Arr(1, 3) = Chr(34)
Arr(1, 4) = Chr(35)
Arr(1, 5) = Chr(37)
Arr(1, 6) = Chr(38)
Arr(1, 7) = Chr(39)
Arr(1, 8) = Chr(40)
Arr(1, 9) = Chr(41)
Arr(1, 10) = Chr(42)
Arr(1, 11) = Chr(43)
Arr(1, 12) = Chr(44)
Arr(1, 13) = Chr(46)
Arr(1, 14) = Chr(47)
Arr(1, 15) = Chr(58)
Arr(1, 16) = Chr(59)
Arr(1, 17) = Chr(92)
Arr(1, 18) = Chr(96)
Arr(1, 19) = Chr(128)
Arr(1, 20) = Chr(129)
Arr(1, 21) = Chr(130)
Arr(1, 22) = Chr(131)
Arr(1, 23) = Chr(132)
Arr(1, 24) = Chr(133)
Arr(1, 25) = Chr(134)
Arr(1, 26) = Chr(135)
Arr(1, 27) = Chr(136)
Arr(1, 28) = Chr(137)
Arr(1, 29) = Chr(138)
Arr(1, 30) = Chr(139)
Arr(1, 31) = Chr(140)
Arr(1, 32) = Chr(141)
Arr(1, 33) = Chr(142)
Arr(1, 34) = Chr(143)
Arr(1, 35) = Chr(144)
Arr(1, 36) = Chr(145)
Arr(1, 37) = Chr(146)
Arr(1, 38) = Chr(147)
Arr(1, 39) = Chr(148)
Arr(1, 40) = Chr(149)
Arr(1, 41) = Chr(150)
Arr(1, 42) = Chr(151)
Arr(1, 43) = Chr(152)
Arr(1, 44) = Chr(153)
Arr(1, 45) = Chr(154)
Arr(1, 46) = Chr(160)
Arr(1, 47) = Chr(161)
Arr(1, 48) = Chr(162)
Arr(1, 49) = Chr(163)
Arr(1, 50) = Chr(164)
Arr(1, 51) = Chr(165)
Arr(1, 52) = Chr(226)
Arr(1, 53) = Chr(232)
Arr(1, 54) = Chr(233)
Arr(1, 55) = Chr(244)
Arr(1, 56) = "__"
Arr(1, 57) = "_-_"
Arr(2, 1) = "_"
Arr(2, 2) = ""
Arr(2, 3) = ""
Arr(2, 4) = ""
Arr(2, 5) = ""
Arr(2, 6) = "_and"
Arr(2, 7) = ""
Arr(2, 8) = ""
Arr(2, 9) = ""
Arr(2, 10) = ""
Arr(2, 11) = "_and"
Arr(2, 12) = ""
Arr(2, 13) = ""
Arr(2, 14) = "-"
Arr(2, 15) = ""
Arr(2, 16) = ""
Arr(2, 17) = "-"
Arr(2, 18) = ""
Arr(2, 19) = "C"
Arr(2, 20) = "u"
Arr(2, 21) = "e"
Arr(2, 22) = "a"
Arr(2, 23) = "a"
Arr(2, 24) = "a"
Arr(2, 25) = "a"
Arr(2, 26) = "c"
Arr(2, 27) = "e"
Arr(2, 28) = "e"
Arr(2, 29) = "e"
Arr(2, 30) = "i"
Arr(2, 31) = "i"
Arr(2, 32) = "i"
Arr(2, 33) = "A"
Arr(2, 34) = "A"
Arr(2, 35) = "E"
Arr(2, 36) = "ae"
Arr(2, 37) = "AE"
Arr(2, 38) = "o"
Arr(2, 39) = "o"
Arr(2, 40) = "o"
Arr(2, 41) = "u"
Arr(2, 42) = "u"
Arr(2, 43) = "y"
Arr(2, 44) = "O"
Arr(2, 45) = "U"
Arr(2, 46) = "a"
Arr(2, 47) = "i"
Arr(2, 48) = "o"
Arr(2, 49) = "u"
Arr(2, 50) = "n"
Arr(2, 51) = "N"
Arr(2, 52) = "a"
Arr(2, 53) = "e"
Arr(2, 54) = "e"
Arr(2, 55) = "o"
Arr(2, 56) = "_"
Arr(2, 57) = "-"

For Rowcounter = 2 To numrows
numrows = numrows - 1

'MsgBox numrows

'Exit Sub
For lCount = 1 To 57
Sheets("data").Range("V" & Rowcounter) = _
Replace(Sheets("data").Range("V" & Rowcounter), Arr(1, lCount), Arr(2, lCount))
Sheets("data").Range("AC" & Rowcounter) = _
Replace(Sheets("data").Range("AC" & Rowcounter), Arr(1, lCount), Arr(2, lCount))
Sheets("data").Range("AD" & Rowcounter) = _
Replace(Sheets("data").Range("AD" & Rowcounter), Arr(1, lCount), Arr(2, lCount))
Next lCount
Next Rowcounter[/vba]

[Tommy]

Hi Alex Wren,

Welcome to VBAX!

I have no data
But this should speed you up

[vba]Sub Hi()
Dim numrows As Integer

Sheets("in").Activate
numrows = Application.CountA(Sheets("in").Range("C1:C10000"), "")

' Less dodgy array for non HTML character replacement

Dim lCount As Long, lNum As Long
Dim Rowcounter As Long
Dim Arr(2, 57)

Arr(1, 1) = Chr(32)
Arr(1, 2) = Chr(33)
Arr(1, 3) = Chr(34)
Arr(1, 4) = Chr(35)
Arr(1, 5) = Chr(37)
Arr(1, 6) = Chr(38)
Arr(1, 7) = Chr(39)
Arr(1, 8) = Chr(40)
Arr(1, 9) = Chr(41)
Arr(1, 10) = Chr(42)
Arr(1, 11) = Chr(43)
Arr(1, 12) = Chr(44)
Arr(1, 13) = Chr(46)
Arr(1, 14) = Chr(47)
Arr(1, 15) = Chr(58)
Arr(1, 16) = Chr(59)
Arr(1, 17) = Chr(92)
Arr(1, 18) = Chr(96)
Arr(1, 19) = Chr(128)
Arr(1, 20) = Chr(129)
Arr(1, 21) = Chr(130)
Arr(1, 22) = Chr(131)
Arr(1, 23) = Chr(132)
Arr(1, 24) = Chr(133)
Arr(1, 25) = Chr(134)
Arr(1, 26) = Chr(135)
Arr(1, 27) = Chr(136)
Arr(1, 28) = Chr(137)
Arr(1, 29) = Chr(138)
Arr(1, 30) = Chr(139)
Arr(1, 31) = Chr(140)
Arr(1, 32) = Chr(141)
Arr(1, 33) = Chr(142)
Arr(1, 34) = Chr(143)
Arr(1, 35) = Chr(144)
Arr(1, 36) = Chr(145)
Arr(1, 37) = Chr(146)
Arr(1, 38) = Chr(147)
Arr(1, 39) = Chr(148)
Arr(1, 40) = Chr(149)
Arr(1, 41) = Chr(150)
Arr(1, 42) = Chr(151)
Arr(1, 43) = Chr(152)
Arr(1, 44) = Chr(153)
Arr(1, 45) = Chr(154)
Arr(1, 46) = Chr(160)
Arr(1, 47) = Chr(161)
Arr(1, 48) = Chr(162)
Arr(1, 49) = Chr(163)
Arr(1, 50) = Chr(164)
Arr(1, 51) = Chr(165)
Arr(1, 52) = Chr(226)
Arr(1, 53) = Chr(232)
Arr(1, 54) = Chr(233)
Arr(1, 55) = Chr(244)
Arr(1, 56) = "__"
Arr(1, 57) = "_-_"
Arr(2, 1) = "_"
Arr(2, 2) = ""
Arr(2, 3) = ""
Arr(2, 4) = ""
Arr(2, 5) = ""
Arr(2, 6) = "_and"
Arr(2, 7) = ""
Arr(2, 8) = ""
Arr(2, 9) = ""
Arr(2, 10) = ""
Arr(2, 11) = "_and"
Arr(2, 12) = ""
Arr(2, 13) = ""
Arr(2, 14) = "-"
Arr(2, 15) = ""
Arr(2, 16) = ""
Arr(2, 17) = "-"
Arr(2, 18) = ""
Arr(2, 19) = "C"
Arr(2, 20) = "u"
Arr(2, 21) = "e"
Arr(2, 22) = "a"
Arr(2, 23) = "a"
Arr(2, 24) = "a"
Arr(2, 25) = "a"
Arr(2, 26) = "c"
Arr(2, 27) = "e"
Arr(2, 28) = "e"
Arr(2, 29) = "e"
Arr(2, 30) = "i"
Arr(2, 31) = "i"
Arr(2, 32) = "i"
Arr(2, 33) = "A"
Arr(2, 34) = "A"
Arr(2, 35) = "E"
Arr(2, 36) = "ae"
Arr(2, 37) = "AE"
Arr(2, 38) = "o"
Arr(2, 39) = "o"
Arr(2, 40) = "o"
Arr(2, 41) = "u"
Arr(2, 42) = "u"
Arr(2, 43) = "y"
Arr(2, 44) = "O"
Arr(2, 45) = "U"
Arr(2, 46) = "a"
Arr(2, 47) = "i"
Arr(2, 48) = "o"
Arr(2, 49) = "u"
Arr(2, 50) = "n"
Arr(2, 51) = "N"
Arr(2, 52) = "a"
Arr(2, 53) = "e"
Arr(2, 54) = "e"
Arr(2, 55) = "o"
Arr(2, 56) = "_"
Arr(2, 57) = "-"
' begin add code
Dim Vrng As Range
Dim ACrng As Range
Dim ADrng As Range
Set Vrng = Sheets("data").Range("V2:V" & CStr(numrows))
Set ACrng = Sheets("data").Range("AC2:AC" & CStr(numrows))
Set ADrng = Sheets("data").Range("AD2:AD" & CStr(numrows))
For lCount = 1 To 57
Vrng.Replace What:=Arr(1, lCount), Replacement:=Arr(2, lCount), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
ACrng.Replace What:=Arr(1, lCount), Replacement:=Arr(2, lCount), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
ADrng.Replace What:=Arr(1, lCount), Replacement:=Arr(2, lCount), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Next lCount
'end add code
'removed code
'''
'''
''' For Rowcounter = 2 To numrows
''' numrows = numrows - 1
'''
''' 'MsgBox numrows
'''
''' 'Exit Sub
''' For lCount = 1 To 57
''' Sheets("data").Range("V" & Rowcounter) = _
Replace(Sheets("data").Range("V" & Rowcounter), Arr(1, lCount), Arr(2, lCount))
''' Sheets("data").Range("AC" & Rowcounter) = _
Replace(Sheets("data").Range("AC" & Rowcounter), Arr(1, lCount), Arr(2, lCount))
''' Sheets("data").Range("AD" & Rowcounter) = _
Replace(Sheets("data").Range("AD" & Rowcounter), Arr(1, lCount), Arr(2, lCount))
''' Next lCount
''' Next Rowcounter
'''
''' Range.Replace What:=Arr(1, lCount), Replacement:=Arr(2, lCount), LookAt:=xlPart, _
''' SearchOrder:=xlByRows, MatchCase:=False
End Sub
[/vba]

[Alex Wren]

Thanks Tommy, that is excellent.

Alex