Below code is counting a final amount of students in a school and average amount of students in a class.
It's running the code until the user types "0".
How can I ensure that the "0 class" won't be counted as an additional class? Currently I am achieving it by subtracting -1 from B, but it's not an elegant solution - calculation is correct, but the class is still listed in final MsgBox.
Btw, if I wanted to end the loop when user is leaving the cell empty, what should I do? Simple Loop Until Zak = "" doesn't work.
Many thanks,
Sub D1()
Dim Zak As Byte
Dim B As Byte, C As Byte
Dim kzak As String
Dim ktrid
Dim trid As Byte
Dim k, l As Integer
B = 0
kzak = ""
Do
Zak = InputBox("Amount of students")
B = B + 1
kzak = kzak & Str(B) & (" class") & (" ") & _
("Students ") & Str(Zak) & Chr(10)
k = k + Zak
Loop Until Zak = 0
C = (B - 1)
l = k / C
MsgBox kzak & Chr(10) & ("At school is ") & Str(k) & (" students") & _
(", on avarage ") & Str(l) & (" in a class")
End Sub
This is a late post, but here is code to accomplish all the requirements you stated with just a few tweaks to your existing code:
Public Sub D2()
Dim Zak As String
Dim B As Integer
Dim kzak As String
Dim k As Integer
Dim l As Integer
B = 0
kzak = ""
Do
Zak = InputBox("Amount of students")
If Val(Zak) > 0 Then
B = B + 1
kzak = kzak & Str(B) & (" class") & (" ") & ("Students ") & Zak & Chr(10)
k = k + Val(Zak)
End If
Loop Until Zak = ""
If B > 0 Then
l = k / B
MsgBox kzak & Chr(10) & ("At school is ") & Str(k) & (" students") & (", on avarage ") & Str(l) & (" in a class")
End If
End Sub
Notice some of the changes I made.
First, I declared the variables more appropriately. Also, with your code k would have been a variant.
Second, I was able to remove the B - 1 hack while also assuring `B' had a value to avoid a divide by zero error.
Third, this code handles Cancel from the InputBox.
A common approach to this is to ask first, and then test with a Do While instead of a Loop Until, and then ask again. Something like this:
Zak = InputBox("Amount of students")
Do While Zak <> 0
...
...
Zak = InputBox("Amount of students")
Loop
Related
I was trying to create a universal, error resistant VBA code that would count words in selected ranges as MS Word does. This below is the best I could do and I was hoping that somebody would have a look and let me know if I missed something or suggest any improvements. The code is quite fast and works with single cell, non-adjacent cells and whole columns, I need it to be as universal as possible. I'll be looking forward to feedback.
Option Explicit
Sub word_count()
Dim r() As Variant 'array
Dim c As Long 'total counter
Dim i As Long
Dim l As Long 'string lenght
Dim c_ch As Long 'character counter
Dim c_s As String 'string variable
Dim cell As range
Dim rng As range
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
ElseIf InStr(1, Selection.Address, ":", vbTextCompare) = 0 And InStr(1, Selection.Address, ",", vbTextCompare) = 0 Then 'for when only one cell is selected
word_count_f Selection.Value, c
MsgBox "Your selected cell '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
Exit Sub
ElseIf InStr(1, Selection.Address, ",", vbTextCompare) > 0 Then 'when user selects more than one cell by clicking one by one -> address looks like ('A1,A2,A3') etc
Application.ScreenUpdating = False
Dim help() As Variant
ReDim help(1 To Selection.Cells.Count)
i = 1
For Each cell In Selection 'loading straigh to array wouldn't work, so I create a helper array
help(i) = cell.Value
i = i + 1
Next cell
r = help
Else 'load selection to array to improve speed
Application.ScreenUpdating = False
r = Selection.Value
End If
Dim item As Variant
For Each item In r
word_count_f item, c
Next item
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
End Sub
Private Function word_count_f(ByVal item As Variant, ByRef c As Long)
Dim l As Long 'lenght variable
Dim c_s As String 'whole string variable
Dim c_ch As Long 'characted count variable
l = Len(item)
If l = 0 Then Exit Function
c_s = item
c_s = Trim(c_s)
Do While InStr(1, c_s, " ", vbTextCompare) > 0 'remove double spaces to improve accuracy
c_s = Replace(c_s, " ", " ")
Loop
If InStr(1, c_s, " ", vbTextCompare) = 0 And l > 0 Then 'if there was just one word in the cell
c = c + 1
ElseIf InStr(1, c_s, " ", vbTextCompare) > 0 Then 'else loop through string to count words
For c_ch = 1 To l 'loop through charactes of the string
If (Mid(c_s, c_ch, 1)) = " " Then
c = c + 1 'for each word
End If
Next c_ch
c = c + 1 'add one for the first word in cell
Else 'hopefully useless msgbox, but I wanted to be sure to inform the user correctly
MsgBox "Sorry, there was an error while processing one of the cells, the result might not be accurate", vbCritical
End If
End Function
You can achieve this in a similar way but with less code if you are interested to see?:
Sub word_count()
start_time = Timer
Dim r As Variant 'temp split array
Dim arr As Variant 'array
Dim c As Long 'total counter
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
Else
c = 0
For Each partial_selection In Split(Selection.Address, ",")
If Range(partial_selection).Cells.Count > 1 Then
arr = Range(partial_selection).Value
Else
Set arr = Range(partial_selection)
'single cell selected don't convert to array
End If
For Each temp_cell In arr
If Len(Trim(temp_cell)) > 0 Then
r = Split(temp_cell, " ")
For Each temp_word In r
If Len(Trim(temp_word)) > 0 Then
c = c + 1
'If the word is just a blank space don't count
End If
Next
'c = c + (UBound(r) - LBound(r) + 1)
'trimmed = Trim(temp_cell)
'c = c + 1 + (Len(trimmed) - Len(Replace(trimmed, " ", "")))
Else 'Blank cell
'Do nothing
End If
Next
Next
End If
Dim item As Variant
time_taken = Round(Timer - start_time, 3)
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") _
& "' in '" & Selection.Parent.Name & "' has " & c & " words." _
& vbNewLine & "Time Taken: " & time_taken & " secs"
Debug.Print c & " in "; time_taken; " secs"
End Sub
You could try this sort of approach? There may be the need to check for the next character to the space being another space, which would need some additions made. To detect word one as being the same as word one in the count. Also, transferring the range to an array would make it a touch faster.
Function Word_Count(rng As Excel.Range) As Long
Dim c As Excel.Range
Dim s As String
Dim l As Long
For Each c In rng.Cells
s = Trim(c.Value)
If s <> "" Then
If InStr(1, s, " ") > 0 Then
' Find number of spaces. You can use the ubound of split maybe here instead
l = l + (Len(s) - Len(Replace(s, " ", "")))
Else
End If
' Will always be 1 word
l = l + 1
End If
Next c
Word_Count = l
Set c = Nothing
End Function
Currently I'm creating a check for a column.
Goal: I have a column called currency which I need to check if they are all the same for each Bank (Column A). If there are other currency then it will prompt me.
Additional goal: I would also like to include in the checking the one in column E (Currency (Bank Charge)) to make sure that all currencies for that bank are the same.
Problem: I already have a working code using scripting.dictionary, however, I have some trouble clearing the dictionary for the first loop / currencies for the first Bank. I tried to clear the dictionary before it proceeds to another bank. But it is not working.
Below is the screenshot of what I would like to check:
Below is the current code that I have:
Sub CurrencyTestCheck()
Dim wksSource As Worksheet: Set wksSource = ThisWorkbook.Sheets("Test1")
Dim i As Long
Dim x As Long
Dim lastRow As Long
Dim strBankName As String
Set d = CreateObject("Scripting.dictionary")
Application.ScreenUpdating = False
lastRow = wksSource.Cells(wksSource.Rows.Count, "C").End(xlUp).Row
For i = 2 To lastRow
If Len(wksSource.Cells(i, 1).Value) > 0 Then 'If a new bank starts
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
countCurrency = d(k)
msg = msg & strCheck & " - " & countCurrency & vbNewLine
x = x + 1
Next k
If x > 1 Then
MsgBox "There are different currencies for bank " & strBankName & vbNewLine & _
vbNewLine & msg, vbCritical, "Warning"
Else
MsgBox "Currencies are all the same for " & strBankName, vbInformation, "Same currencies"
End If
d.RemoveAll
End If
strBankName = wksSource.Cells(i, 1).Value
End If
'Currency for each Bank
tmp = Trim(wksSource.Cells(i, 3).Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next i
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
countCurrency = d(k)
msg = msg & strCheck & " - " & countCurrency & vbNewLine
x = x + 1
Next k
If x > 1 Then
MsgBox "There are different currencies for bank " & strBankName & vbNewLine & _
vbNewLine & msg, vbCritical, "Warning"
Else
MsgBox "Currencies are all the same for " & strBankName, vbInformation, "Same currencies"
End If
End If
Application.ScreenUpdating = True
End Sub
Output:
Previous values are still in the dictionary (USD - 3 and AUD - 2)
Appreciate if you also have another suggestion to do the checking.
You might have forgotten to reset your currency discrepancy counter x.
Set it to x = 0 after the first bank's loop.
i.e.
...
...
'Currency for each Bank
tmp = Trim(wksSource.Cells(i, 3).Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next i
' Add these two lines:
x = 0
msg = ""
If Len(strBankName) > 0 Then
For Each k In d.Keys
strCheck = k
...
...
And like TinMan said, also reset the msg so the previous bank's results don't leak into your the next bank.
in a VBA excel macro I am using, I have the following code:
For k = MinDeg To MaxDeg
OutputStr = Trim(OutputStr & "a" & Str(k) & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next k
Where "MyCoe" and "MyErr" are given numbers, and "minDeg" and "MaxDeg" are integers.
My question is:
How can I make "Str(k)" appear in the outputstr as subscript text?
If Unicode is available in your environment, another option would be to use the subscripted Unicode characters for Str(K). Making some modifications to Gary's Student code so as to get output in A1:
Option Explicit
Sub foo()
Dim K As Long
Const MinDeg As Long = 10
Const MaxDeg As Long = 13
Dim sK As String, I As Long
Const MyCoe As Long = 3
Const MyErr As Long = 5
Dim OutPutStr As String
For K = MinDeg To MaxDeg
sK = ""
For I = 1 To Len(CStr(K))
sK = sK & ChrW(832 & Mid(CStr(K), I, 1))
Next I
OutPutStr = Trim(OutPutStr & "a" & sK & " = " & _
Str(MyCoe) & " ± " & _
Str(MyErr) & Chr(10))
Next K
Cells(1, 1) = OutPutStr
End Sub
Note that the subscripted values also appear in the formula bar.
First I run this simple mod to your code:
Sub WhatEverr()
mindeg = 10
maxdeg = 13
mycoe = 3
myerr = 5
For k = mindeg To maxdeg
outputstr = Trim(outputstr & "a" & Str(k) & " = " & _
Str(mycoe) & " ± " & _
Str(myerr) & Chr(10))
Next k
Range("A1").Value = outputstr
End Sub
to get this in A1:
Then I run:
Sub formatcell()
Dim i As Long, L As Long, rng As Range
Dim s As String
Set rng = Range("A1")
s = rng.Value
L = Len(s)
For i = 1 To L
ch = Mid(s, i, 1)
If ch = "a" Then
rng.Characters(Start:=i + 2, Length:=2).Font.Subscript = True
End If
Next i
End Sub
To apply the format:
In Excel, this type of character formatting is a property of the Range object. You do not build it into the string like you would in HTML.
I am running into an issue that is driving me crazy. I have two FOR loops in my macro that each have a counter to keep track of how many times a certain process was performed. The counters work great and at the end of the loop contain the correct numbers. The next thing I have to do is to format the counts into a five digit number with leading zeros. I have tried this using two different approaches (see below).
cCount = String(5 - Len(cTemp), "0") & cTemp
mCount = String(5 - Len(mTemp), "0") & mTemp
or
cCount = Format(cTemp, "00000")
mCount = Format(mTemp, "00000")
The problem is with the second counter. As I step through it, the first format formula works, but the second line does not, regardless of which version above that I use. Now here is the thing, if, while I am still in the macro, I go and change the name of mCount to anything else, for example mCnt, and then move the macro step back up to reprocess that line, it will correctly format the variable. But it isn't the name, because if I then run the macro again using mCnt, it will do the same thing. I can change it back to mCount and it will work.
All variables are dimmed as Integers. An example of what I am looking for would be if mTemp is 15, then mCount would be 00015. However, mCount is just coming back as 15. cCount is working fine.
The fact that everything is correct and that I can make it work if I pause the macro, change the variable name, and reprocess the line, has got me completely at a loss as to what the issue is.
Sub MakePay()
Dim strFileToOpen As String
Dim payDate, payTab, payCheckTemp, payCheck, payAccTemp As String
Dim payAcc, payAmount, payTotalC, payTotalM As String
Dim savePath As String
Dim payFileNameCLP, payFileNameMF As String
Dim payString1, payString2, payString3, payString4, payString5, payString6 As String
Dim payString7, payString8, payString9 As String
Dim rCnt, i, j, cTemp, cCount, mTemp, mCount As Integer
Dim payTotalMTemp, payAmountTemp, payTotalCTemp As Double
' Set date
payDate = Format(Now(), "yyyymmddhhmmss")
' Ask for check number and format to field length
payCheckTemp = InputBox("Please enter the check number.")
payCheck = payCheckTemp & String(15 - Len(payCheckTemp), " ")
' Create file names and open text files for writing
payFileNameCLP = "CLP_" & payDate & "_01.txt"
payFileNameMF = "MDF_" & payDate & "_01.txt"
savePath = Environ("USERPROFILE") & "\Desktop\"
Open savePath & payFileNameCLP For Output As #1
Open savePath & payFileNameMF For Output As #2
' Build header rows and print them
payString1 = "100"
payString2 = "200 C"
Print #1, payString1
Print #1, payString2
Print #2, payString1
Print #2, payString2
' reset counters for number of claims and total dollar amounts in files
cTemp = 0
mTemp = 0
payTotalCTemp = 0
payTotalMTemp = 0
For i = 1 To Sheets.Count
' Process the Clearpoint tab
If Left(Sheets(i).Name, 3) = "CLE" Then
Sheets(i).Activate
rCnt = Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To (rCnt - 1)
' Read accession # and format it for field length
payAccTemp = Cells(j, 3).Value
payAcc = payAccTemp & String(17 - Len(payAccTemp), " ")
' Read payment amount, if $0, skip
payAmountTemp = Format(Cells(j, 5).Value2, "#,###.00")
If payAmountTemp = "" Then
GoTo SkipCDL
End If
' Add payment to total Clearpoint payments
payTotalCTemp = payTotalCTemp + payAmountTemp
' Format payment by deleting decimal and then format to field length
payAmount = Format(payAmountTemp * 100, "0000000;-000000")
' Build payment strings and print them
payString3 = "400" & String(10, " ") & payAcc & payCheck
payString4 = "450" & String(10, " ") & payAcc & String(150, " ") & payAmount
payString5 = "500" & String(10, " ") & payAcc & String(73, " ") & payAmount
Print #1, payString3
Print #1, payString4
Print #1, payString5
' Increase Clearpoint patient count
cTemp = cTemp + 1
SkipCDL:
Next j
' Process Medfusion tab
ElseIf Left(Sheets(i).Name, 3) = "MED" Then
Sheets(i).Activate
rCnt = Cells(Rows.Count, 1).End(xlUp).Row
For j = 3 To (rCnt - 1)
' Read accession # and format it for field length
payAccTemp = Cells(j, 3).Value
payAcc = payAccTemp & String(17 - Len(payAccTemp), " ")
' Read payment amount, if $0, skip
payAmountTemp = Format(Cells(j, 5).Value2, "#,###.00")
If payAmountTemp = "" Then
GoTo SkipMDF
End If
' Add payment to total Medfusion payments
payTotalMTemp = payTotalMTemp + payAmountTemp
' Format payment by deleting decimal and then format to field length
payAmount = Format(payAmountTemp * 100, "0000000;-000000")
' Build payment strings and print them
payString3 = "400" & String(10, " ") & payAcc & payCheck
payString4 = "450" & String(10, " ") & payAcc & String(150, " ") & payAmount
payString5 = "500" & String(10, " ") & payAcc & String(73, " ") & payAmount
Print #2, payString3
Print #2, payString4
Print #2, payString5
' Increase Medfusion count
mTemp = mTemp + 1
SkipMDF:
Next j
End If
Next i
' Format patient counter and total payment to field length
cCount = Format(cTemp, "00000")
mCount = Format(mTemp, "00000")
payTotalC = Format(payTotalCTemp * 100, "000000000;-00000000")
payTotalM = Format(payTotalMTemp * 100, "000000000;-00000000")
' Build footer strings and print them
payString6 = "800" & String(26, " ") & "9999" & cCount & String(131, " ") & payTotalC
payString7 = "800" & String(26, " ") & "9999" & mCount & String(131, " ") & payTotalM
payString8 = "900" & String(57, " ") & "099990" & cCount & String(154, " ") & String(2, "0") & payTotalC
payString9 = "900" & String(57, " ") & "099990" & mCount & String(154, " ") & String(2, "0") & payTotalM
Print #1, payString6
Print #2, payString7
Print #1, payString8
Print #2, payString9
' Close all files
Application.DisplayAlerts = False
Close #1
Close #2
Application.DisplayAlerts = True
End Sub
The issue is with how the variables are declared.
In VBA/classic vb, all declarations should be on their own line OR have the correct data type specified, otherwise you risk accidentally creating a Variant data type, which can masquerade as any other data type, which the VB engine has rules for determining the type.
See https://msdn.microsoft.com/en-us/library/56ht941f(v=vs.90).aspx
Also, whenever coding in VBA make sure Option Explicit is declared at the top of any new code module. It will save you loads of pain in the future.
Also, you are trying to push String formatting into an Integer, which cannot happen.
So...
Option Explicit
.....
'Dim i, j as Integer 'BAD i is a variant, j is an integer
Dim i As Integer
Dim j As Integer 'GOOD both are Integers
'OR
Dim x As Integer, y as Integer 'I believe this will work too
dim displayI as String
i = 23
displayI = Format(i, "00000")
In your code why not just format inline?
payString6 = "800" & String(26, " ") & "9999" & Format(cCount,"00000") & String(131, " ") & payTotalC
I have address lists that sometimes have junk at the end of the street suffix that needs to be removed. For example Yada Yada St. apt#12 needs to become Yada Yada St. Now, I have found a list of street suffixes and their variations from here. I need to do this all in excel so I put the 3 column list of suffixes (columns 1-3 being Primary Street Suffix, Commonly Used Street Suffix or Abbreviation, and Postal Service Standard Suffix Abbreviation respectively) into a worksheet labeled SuffixList and I put the address list into sheet 1 which is where the code is.
I created a code to check each address against each suffix variation (column 2 on SuffixList) using a space before and after the suffix I'm checking to make sure I'm not catching any street names, just the street suffixes. I also have the . and , variations being checked in the code as you can see below. The code I'm using now works, it just takes too long and I'm looking for a faster method.
Also, any time I find a match, I am replacing the street suffix used with the officially correct one (column 3 on suffix list).
Current Code:
Sub JunkRemover()
'Link to an official abbreviations list
'https://www.usps.com/send/official-abbreviations.htm
Dim Orig As String
Dim NewAddr As String
Dim x As Integer 'Row Reference
Dim i As Long 'Address List Iterator
Dim y As Integer 'SuffixList Iterator
Dim ChangeCount As Integer
'WARNING!!!!!!!!!!!!
'This code assumes address field is in column A and that the address column has no blanks.
'If that is not the case, replace 1 for the appropriate number for x
'a=1, b=2, c=3, d=4 etc.
x = 1
ChangeCount = 0
i = 2
While Cells(i, x) <> ""
Orig = UCase(Cells(i, x))
y = 2
While Sheets("SuffixList").Cells(y, 2) <> ""
If InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 2) & " ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 3) & " ")) + Len(Sheets("SuffixList").Cells(y, 3)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
ElseIf InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 2) & ". ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 3) & ". ")) + Len(Sheets("SuffixList").Cells(y, 3)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
ElseIf InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 2) & ", ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(Sheets("SuffixList").Cells(y, 3) & ", ")) + Len(Sheets("SuffixList").Cells(y, 3)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
End If
y = y + 1
Wend
i = i + 1
Wend
MsgBox ChangeCount & " Rows Changed", vbOKOnly
End Sub
Further Examples:
OrigAddress NewAddress
4000 NO MAIN ST 1 4000 NO MAIN ST
135 ALDEN ST APT3 135 ALDEN ST
1820 HIGHLAND AVE 1820 HIGHLAND AVE
4901 NO MAIN ST. REAR 4901 NO MAIN ST
1820 HIGHLAND AVE, 1 1820 HIGHLAND AVE
Final Code users Potter's answer:
Sub JunkRemover2()
'Link to an official abbreviations list
'https://www.usps.com/send/official-abbreviations.htm
Dim Orig As String
Dim NewAddr As String
Dim x As Integer 'Row Reference
Dim i As Long 'Address List Iterator
Dim y As Integer 'SuffixList Iterator
Dim ChangeCount As Integer
Dim PauseTime, Start, Finish, TotalTime As Double
Dim slRows As Double
Dim slCols As Integer
Dim slRowsAddr As Double
Dim slColsAddr As Integer
'WARNING!!!!!!!!!!!!
'This code assumes address field is in column A and that the address column has no blanks.
'If that is not the case, replace 1 for the appropriate number for x
'a=1, b=2, c=3, d=4 etc.
x = 1
ChangeCount = 0
With Sheets("SuffixList")
'i am using Column 1 to find out how many rows there are(change it if you want)
slRows = Sheets("SuffixList").Cells(Rows.Count, 1).End(xlUp).Row
slCols = Sheets("SuffixList").Cells(1, Columns.Count).End(xlToLeft).Column
suffixData = Sheets("SuffixList").Range(Sheets("SuffixList").Cells(2, 2), Sheets("SuffixList").Cells(slRows, slCols))
End With
i = 2
While Cells(i, x) <> ""
Orig = UCase(Cells(i, x))
For y = 1 To slRows - 1
If InStr(1, Orig, " " & UCase(suffixData(y, 1) & " ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(suffixData(y, 2) & " ")) + Len(suffixData(y, 2)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
Exit For
ElseIf InStr(1, Orig, " " & UCase(suffixData(y, 1) & ". ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(suffixData(y, 2) & ". ")) + Len(suffixData(y, 2)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
Exit For
ElseIf InStr(1, Orig, " " & UCase(suffixData(y, 1) & ", ")) > 1 Then
NewAddr = Left(Orig, InStr(1, Orig, " " & UCase(suffixData(y, 2) & ", ")) + Len(suffixData(y, 2)))
Cells(i, x) = NewAddr
ChangeCount = ChangeCount + 1
Exit For
End If
Next
i = i + 1
Wend
MsgBox ChangeCount & " Rows Changed", vbOKOnly
End Sub
You're right; it is slow because every time you compare stuff you access the Excel application, which is considerably slower than just accessing, say, a variable.
I would suggest you copy the relevant fields you want to arrays like so:
dim suffixData as variant
'Now you need to save all that sheets' content into an array
'1stly you need the sheet's dimentions
dim slRows as double
dim slCols as integer
'I am using Column 1 to find out how many rows there are(change it if you want)
with Sheets("SuffixList")
slRows = .Cells(rows.count, 1).end(xlUp).row
slCols = .Cells(1, columns.count).end(xlToLeft).column
suffixData = .Range(.cells(1,1), .cells(slRows, slCols))
end with
From here onwards you should use suffixData(row, column) to access that sheet as if it was the actual sheet. On a thousand+ iterations on it you will see a definite improvements.
You can do the same trick with the other sheets and calculate everything without even looking up Excel while you do your costly loops.
The reverse is also advisable. You don't want to write to a cell each time you have its value.
It's much better to write it to a 2D array as if it was the spreadsheet and then copy the entire array to the sheet.