Excel VBA "else" statement counting wrongly - vba

I have created an "If ElseIf Else" statement that will count the strings in a strings. It does count the keywords/strings that I want to be counted but it is counting the "others"/ Else items wrongly. As shown below highlighted in red, I should only have 6 strings that should be labelled as "others" but it counted as 8. It is a total of 18 rows but on the total results it counted it as 20.
I am newby in VBA and needing experts advise. Thank you.
Option Compare Text
Public Sub Keywords()
Dim row_number As Long
Dim count_of_corp_or_windows As Long
Dim count_of_mcafee As Long
Dim count_of_token As Long
Dim count_of_host_or_ipass As Long
Dim count_of_others As Long
Dim count_of_X As Long
Dim count_of_all As Long
Dim items As Variant
row_number = 0
count_of_corp_or_windows = 0
count_of_mcafee = 0
count_of_token = 0
count_of_host_or_ipass = 0
count_of_X = 0
count_of_others = 0
count_of_all = 0
Do
row_number = row_number + 1
items = Sheets("LoginPassword").Range("N" & row_number)
If InStr(items, "corp") Or InStr(items, "windows") Then
count_of_corp_or_windows = count_of_corp_or_windows + 1
ElseIf InStr(items, "mcafee") Then
count_of_mcafee = count_of_mcafee + 1
ElseIf InStr(items, "token") Then
count_of_token = count_of_token + 1
ElseIf InStr(items, "host") Or InStr(items, "ipass") Then
count_of_host_or_ipass = count_of_host_or_ipass + 1
ElseIf InStr(items, "X A") Then
count_of_X = count_of_X + 1
Else:
count_of_others = count_of_others + 1
End If
Loop Until items = ""
count_of_all = count_of_corp_or_windows + count_of_mcafee + count_of_token + count_of_host_or_ipass + count_of_X + count_of_others
Range("N2").Select
Selection.End(xlDown).Select
lastCell = ActiveCell.Address
ActiveCell.Offset(3, 0).Value = "Count"
ActiveCell.Offset(4, 0).Value = count_of_corp_or_windows
ActiveCell.Offset(5, 0).Value = count_of_mcafee
ActiveCell.Offset(6, 0).Value = count_of_token
ActiveCell.Offset(7, 0).Value = count_of_host_or_ipass
ActiveCell.Offset(8, 0).Value = count_of_X
ActiveCell.Offset(9, 0).Value = count_of_others
ActiveCell.Offset(11, 0).Value = count_of_all
ActiveCell.Offset(3, 1).Value = "Keywords"
ActiveCell.Offset(4, 1).Value = "Corp or Windows"
ActiveCell.Offset(5, 1).Value = "Mcafee"
ActiveCell.Offset(6, 1).Value = "Token"
ActiveCell.Offset(7, 1).Value = "Host or ipass"
ActiveCell.Offset(8, 1).Value = "X accounts"
ActiveCell.Offset(9, 1).Value = "Others"
ActiveCell.Offset(11, 1).Value = "Total"
ActiveCell.Offset(3, -1).Value = "Percent"
ActiveCell.Offset(4, -1).Value = count_of_corp_or_windows / count_of_all
ActiveCell.Offset(5, -1).Value = count_of_mcafee / count_of_all
ActiveCell.Offset(6, -1).Value = count_of_token / count_of_all
ActiveCell.Offset(7, -1).Value = count_of_host_or_ipass / count_of_all
ActiveCell.Offset(8, -1).Value = count_of_X / count_of_all
ActiveCell.Offset(9, -1).Value = count_of_others / count_of_all
End Sub

You should start row_number at 2 instead of 1 because cell N1 contains "Short Description" which you probably do not want to match to anything?
Also you are looping Until a blank cell but the blank cell has already been counted as an "other" cell so this plus the "Short Description" cell probably accounts for the 2 unexpected other cells that are counted. So probably just change row_number = 0 to row_number = 1 and Else: to ElseIf items <> "" then

count_of_others is never set to zero after an iteration since it is out of the loop. This should happen for other counter variables too.

Delete the colon from after your Else and try again.
See this answer for reference.

Related

Macro not working properly: how to highlight entire rows if the direction is not matching the qty values

I'm attempting to loop through my data and highlight the rows that have a direction value that do not match the values set forth by the numbers. Just for your knowledge, sell short means that you are selling stock you don't own. Sell long means that you are selling stocks you own. We are to assume that each of the securities start out with quantity 0. I'm posted an example of the data and my code. Thanks!
Sub TurnRed()
Dim counter As Integer
Dim qtyGHI As Integer
Dim qtyABC As Integer
Dim qtyDEF As Integer
Dim direction As String
qtyGHI = 0
qtyABC = 0
qtyDEF = 0
For counter = 2 To counter = 9
direction = Cells(counter, "C").Value
If Cells(counter, "E").Value = "GHI US" Then
Select Case direction
Case direction = "Buy"
qtyGHI = qtyGHI + Cells(counter, "D").Value
Case direction = "Sell_short"
If qtyGHI - Range("Di").Value > 0 Then
Cells(counter, 1).EntireRow.Interior.Color = vbRed
Case direction = "Sell_long"
If qtyGHI - Range("Di").Value < 0 Then
Cells(counter, 1).EntireRow.Interior.Color = vbRed
End Select
ElseIf Cells(counter, "E").Value = "ABC US" Then
Select Case direction
Case "Buy"
qtyABC = qtyABC + Cells(counter, "D").Value
Case "Sell_short"
If qtyABC - Range("Di").Value > 0 Then
Cells(counter, 1).EntireRow.Interior.Color = vbRed
Case "Sell_long"
If qtyABC - Range("Di").Value < 0 Then
Cells(counter, 1).EntireRow.Interior.Color = vbRed
End Select
ElseIf Cells(counter, "E").Value = "DEF US" Then
Select Case direction
Case direction = "Buy"
qtyDEF = qtyDEF + Cells(counter, "D").Value
Case direction = "Sell_short"
If qtyDEF - Range("Di").Value > 0 Then
Cells(counter, 1).EntireRow.Interior.Color = vbRed
Case direction = "Sell_long"
If qtyDEF - Range("Di").Value < 0 Then
Cells(counter, 1).EntireRow.Interior.Color = vbRed
End Select
Next counter
End If
End Sub
Since you are not being clear; this is the best code, based on your data example, i could produce. It should give you a start.
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
Dim myNmbr As Long
With ws
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'set up the last row
For i = 2 To lr 'loop from row2 to the last row
'the next line test the values in col3 and col5 and adjust the Variable myNmbr to the value in col4.
'it will update the variable if the conditions match again
If .Cells(i, 3).Value = "Buy" And .Cells(i, 5).Value Like "GHI US" Then myNmbr = .Cells(i, 4).Value
'the next line test the values in col3 and col5 and if match checks the cell in col4 against the Variable myNmbr
If .Cells(i, 3).Value = "Sell_Short" And .Cells(i, 5).Value Like "ABC US" And .Cells(i, 4).Value <> myNmbr Then
'If the Value in col4, does not match the Variable myNmbr it colors the cells in the row from col1 to col7
ws.Cells(i, 1).Resize(, 7).Interior.ColorIndex = 3
End If
'the next line does the same test but for "Sell_Long" and "GHI US"
If .Cells(i, 3).Value = "Sell_Long" And .Cells(i, 5).Value Like "GHI US" And .Cells(i, 4).Value <> myNmbr Then
'colors the range the same as above
ws.Cells(i, 1).Resize(, 7).Interior.ColorIndex = 3
End If
Next i
End With

VBA: InStr "OR" issue

I am having issue with my InStr "OR" code. This code: If InStr(items, "harmo") Or InStr(items, "pointt") Then count_of_Harmo = count_of_Harmo + 1
is able to execute well (Highlighted in red below) but this one doesn't ElseIf InStr(items, "addi") Or InStr(items, "add-i") Or InStr(items, "plug") Then count_of_Addi = count_of_Addi + 1(Highlighted in blue below). Please don't mind the other results/counts on the image below as i was not able to capture the whole page as it I think it is relevant to the case. Please see the full code below too. Thank you.
Option Compare Text
Public Sub Keywords_Outlook()
Dim row_number As Long
Dim count_of_Harmo As Long
Dim count_of_Room As Long
Dim count_of_Skyp As Long
Dim count_of_Detach As Long
Dim count_of_Wire As Long
Dim count_of_Addi As Long
Dim count_of_crash As Long
Dim count_of_share As Long
Dim count_of_signa As Long
Dim count_of_passw As Long
Dim count_of_follo_and_ops As Long
Dim count_of_follo_and_req As Long
Dim count_of_others As Long
Dim items As Variant
Dim cursht As String 'for the macro to run in any sheet
cursht = ActiveSheet.Name 'for the macro to run in any sheet
row_number = 1
count_of_Harmo = 0
count_of_Room = 0
count_of_Skyp = 0
count_of_Detach = 0
count_of_Wire = 0
count_of_Addi = 0
count_of_crash = 0
count_of_share = 0
count_of_signa = 0
count_of_passw = 0
count_of_follo_and_ops = 0
count_of_follo_and_req = 0
count_of_others = 0
count_of_all = 0
Do
row_number = row_number + 1
items = Sheets(cursht).Range("N" & row_number)
If InStr(items, "harmo") Or InStr(items, "pointt") Then
count_of_Harmo = count_of_Harmo + 1
ElseIf InStr(items, "room") Then
count_of_Room = count_of_Room + 1
ElseIf InStr(items, "skyp") Then
count_of_Skyp = count_of_Skyp + 1
ElseIf InStr(items, "detach") Then
count_of_Detach = count_of_Detach + 1
ElseIf InStr(items, "wire") Then
count_of_Wire = count_of_Wire + 1
ElseIf InStr(items, "addi") Or InStr(items, "add-i") Or InStr(items, "plug") Then
count_of_Addi = count_of_Addi + 1
ElseIf InStr(items, "crash") Or InStr(items, "car") Then
count_of_crash = count_of_crash + 1
ElseIf InStr(items, "share") Then
count_of_share = count_of_share + 1
ElseIf InStr(items, "signa") Then
count_of_signa = count_of_signa + 1
ElseIf InStr(items, "passw") Then
count_of_passw = count_of_passw + 1
ElseIf Trim(items) Like "*followu*" And Trim(items) Like "*ops*" Then
count_of_follo_and_ops = count_of_follo_and_ops + 1
ElseIf Trim(items) Like "*followu*" And Trim(items) Like "*req*" Then
count_of_follo_and_req = count_of_follo_and_req + 1
ElseIf items <> "" Then
count_of_others = count_of_others + 1
End If
Loop Until items = ""
count_of_all = count_of_Harmo + count_of_Room + count_of_Skyp + count_of_Detach + count_of_Wire + count_of_Addi + count_of_crash + count_of_signa + count_of_passw + count_of_follo_and_ops + count_of_follo_and_req + count_of_others
Range("N2").Select
Selection.End(xlDown).Select
lastCell = ActiveCell.Address
ActiveCell.Offset(3, 0).Value = "Count"
ActiveCell.Offset(4, 0).Value = count_of_Harmo
ActiveCell.Offset(5, 0).Value = count_of_Room
ActiveCell.Offset(6, 0).Value = count_of_Skyp
ActiveCell.Offset(7, 0).Value = count_of_Detach
ActiveCell.Offset(8, 0).Value = count_of_Wire
ActiveCell.Offset(9, 0).Value = count_of_Addi
ActiveCell.Offset(10, 0).Value = count_of_crash
ActiveCell.Offset(11, 0).Value = count_of_share
ActiveCell.Offset(12, 0).Value = count_of_signa
ActiveCell.Offset(13, 0).Value = count_of_passw
ActiveCell.Offset(14, 0).Value = count_of_follo_and_ops
ActiveCell.Offset(15, 0).Value = count_of_follo_and_req
ActiveCell.Offset(16, 0).Value = count_of_others
ActiveCell.Offset(18, 0).Value = count_of_all
ActiveCell.Offset(3, 1).Value = "Outlook Keywords"
ActiveCell.Offset(4, 1).Value = "Harmo"
ActiveCell.Offset(5, 1).Value = "Room"
ActiveCell.Offset(6, 1).Value = "Skyp"
ActiveCell.Offset(7, 1).Value = "Detach"
ActiveCell.Offset(8, 1).Value = "Wire"
ActiveCell.Offset(9, 1).Value = "Addi or add-i or plug"
ActiveCell.Offset(10, 1).Value = "Crash"
ActiveCell.Offset(11, 1).Value = "Share"
ActiveCell.Offset(12, 1).Value = "Signa"
ActiveCell.Offset(13, 1).Value = "passw"
ActiveCell.Offset(14, 1).Value = "FollowU and ops"
ActiveCell.Offset(15, 1).Value = "FollowU and req"
ActiveCell.Offset(16, 1).Value = "Others"
ActiveCell.Offset(18, 1).Value = "Total"
ActiveCell.Offset(3, -1).Value = "Percent"
ActiveCell.Offset(4, -1).Value = count_of_Harmo / count_of_all
ActiveCell.Offset(5, -1).Value = count_of_Room / count_of_all
ActiveCell.Offset(6, -1).Value = count_of_Skyp / count_of_all
ActiveCell.Offset(7, -1).Value = count_of_Detach / count_of_all
ActiveCell.Offset(8, -1).Value = count_of_Wire / count_of_all
ActiveCell.Offset(9, -1).Value = count_of_Addi / count_of_all
ActiveCell.Offset(10, -1).Value = count_of_crash / count_of_all
ActiveCell.Offset(11, -1).Value = count_of_share / count_of_all
ActiveCell.Offset(12, -1).Value = count_of_signa / count_of_all
ActiveCell.Offset(13, -1).Value = count_of_passw / count_of_all
ActiveCell.Offset(14, -1).Value = count_of_follo_and_ops / count_of_all
ActiveCell.Offset(15, -1).Value = count_of_follo_and_req / count_of_all
ActiveCell.Offset(16, -1).Value = count_of_others / count_of_all
End Sub
In an entire If/ElseIf statement, each branch can only execute if all preceding branches did not.
The cell circled in blue triggered the Harmo branch and it cannot trigger any other branches.
If you don't want that to happen, make each branch a separate If/End If statement.
On a side note, you should consider explicitly comparing the result of InStr to zero in all cases. It works currently because you are only using Or, but if you decide to make the condition more complex it might stop working.
Looking at your code, there is a much more efficient and shorter (code wise) to go.
Switch your multiple ElseIf with Select Case, and instead of having 14 counters, why not use an array of counters CountofArr ?
See sample code below, you can continue the implementation easily :
Option Compare Text
Public Sub Keywords_Outlook()
Dim row_number As Long, LastRow As Long
' use an array that will have multiple counters
Dim CountofArr() As Long
ReDim CountofArr(0 To 14)
Dim items As Variant
Dim cursht As String 'for the macro to run in any sheet
cursht = ActiveSheet.Name ' for the macro to run in any sheet
With Sheets(cursht)
LastRow = .Cells(.Rows.Count, "N").End(xlUp).Row ' get last row with data in column "N"
For row_number = 1 To LastRow
items = .Range("N" & row_number).Value2
Select Case True
Case items Like "*harmo*", items Like "*pointt*"
CountofArr(0) = CountofArr(0) + 1
Case items Like "*room*"
CountofArr(1) = CountofArr(1) + 1
' add the rest of your cases below
End Select
Next row_number
' read the array direclty to the cells
For row_number = 4 To 18
.Range("O" & row_number).Value = CountofArr(row_number - 4)
Next row_number
' rest of your code
End With
End Sub

Speeding up VBA Macro with multiple 'For' and 'if' statements

This macro takes 2+ minutes to run. What are the best methods to optimize the macro?
Sub Time_Color(z, k)
Application.DisplayAlerts = False
For Each cell In Sheet1.Range("C" & z & ":" & "LZ" & z)
If cell.Value <> "x" Then
If cell.Value < Sheet3.Range("D" & k) Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = Sheet4.Range("D" & k).Value & "_" & Sheet4.Cells(k, 5).Value
End If
For j = 5 To 1000 Step 2
If cell.Value > Sheet3.Cells(k, j).Value And cell.Value < Sheet3.Cells(k, j + 1).Value Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = Sheet4.Cells(k, j + 1).Value & "_" & Sheet4.Cells(k, j + 2).Value
End If
Next j
For j = 4 To 1000 Step 2
If cell.Value >= Sheet3.Cells(k, j).Value And cell.Value <= Sheet3.Cells(k, j + 1).Value Then
cell.Interior.ColorIndex = 43
cell.Offset(1, 0).Value = Sheet4.Cells(k, j).Value & "_" & Sheet4.Cells(k, j + 1).Value
End If
Next j
End If
Next cell
Application.DisplayAlerts = True
End Sub
I am running this macro for 24 different combinations of z,k.
Try caching as much data as possible, for instance Sheet3.Range("D" & k) is constant throughout this function.
Every instance of the inner most loop will query that cell. If you put it at the beginning of this function, it will be looked up once and then used for the remainder of the function.
Edit:
In the comments on this question is - I think - a better answer by Tim Williams, which is specific to VBA:
Turn off ScreenUpdating and Calculation while running. Calculation
should be reset before your Sub ends (ScreenUpdating will reset
itself)
I'm not entirely sure what you are trying to accomplish, but it seems that your loop iterates over a large range to find the last-most instance of a cell that satisfies one of the two given criteria (your two loops).
If that is the goal, why not start from the back? Depending on how your sheet looks, this is potentially a lot faster!
I also made some other changes. Let me know how it works.
Take care to also include the function at the bottom (heisted from this answer), or substitute it for your function of choice.
Sub Time_Color(z, k)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim loopVal, loopVal2, loopVal3 As Variant
Dim setOdd, setEven, OddEven As Boolean
Dim compVal, compVal2, compVal3 As Variant
compVal = Sheet3.Range("D" & k).Value
compVal2 = Sheet4.Range("D" & k).Value
compVal3 = Sheet4.Cells(k, 5).Value
For Each cell In Sheet1.Range("C" & z & ":" & "LZ" & z)
If cell.Value <> "x" Then
If cell.Value < compVal Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = compVal2 & "_" & compVal3
End If
For j = 1000 To 4 Step -1
loopVal = Sheet3.Cells(k, j).Value
loopVal2 = Sheet3.Cells(k, j + 1).Value
loopVal3 = Sheet4.Cells(k, j + 1).Value
OddEven = OddOrEven(j)
If OddEven = True Then
If cell.Value > loopVal And cell.Value < loopVal2 Then
cell.Interior.ColorIndex = 37
cell.Offset(1, 0).Value = loopVal3 & "_" & Sheet4.Cells(k, j + 2).Value
setOdd = True
End If
Else
If cell.Value >= loopVal And cell.Value <= loopVal2 Then
cell.Interior.ColorIndex = 43
cell.Offset(1, 0).Value = Sheet4.Cells(k, j).Value & "_" & loopVal3
setEven = True
End If
End If
If setEven = True And setOdd = True Then Exit For
Next j
End If
Next cell
Application.DisplayAlerts = True
End Sub
Function OddOrEven(a As Integer) As Boolean ' Returns TRUE if a is an odd number
If a - (2 * (Fix(a / 2))) <> 0 Then OddOrEven = True
End Function

Merging over 2000 Cells using VBA?

I have wrote the following code to merge cells in excel, the data is around 26000 rows, the code is running on core I7 CPU with 8 GB RAM, the problem that it still working since 4 days, the average rows per day is 3000 row!, any one know how to get the result, because its a report that should be delivered since three days!
Sub MergeCellss()
lastRow = Worksheets("A").Range("A65536").End(xlUp).Row
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
For i = 2 To lastRow
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value <> Cells(i + 1, 2).Value Then
intUpper = i
Debug.Print ("<> -1 and <> +1 " & intUpper)
End If
If Cells(i, 2).Value <> Cells(i - 1, 2).Value And Cells(i, 2).Value = Cells(i + 1, 2).Value Then
intUpper = i
Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
End If
If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Application.DisplayAlerts = False
Debug.Print ("<> +1 and = -1:" & i & "LOWER LIMIT")
DoEvents
For x = 1 To 8
Range(Cells(intUpper, x), Cells(i, x)).Merge
Next x
For j = 18 To 26
Range(Cells(intUpper, j), Cells(i, j)).Merge
Next j
Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(i) & ","">0"")"
Range(Cells(intUpper, 14), Cells(i, 14)).Merge
Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
If Cells(i, 2).Value <> Cells(i + 1, 2).Value And Cells(i, 2).Value <> Cells(i - 1, 2).Value Then
Debug.Print ("One Cells: " & i)
Range(Cells(i, 1), Cells(i, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
Cells(intUpper, 14).Value = Cells(intUpper, 13).Value
DoEvents
End If
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
the code above will merge the all cells containing repeated data like User Name, Date of Birth, .... into one cell, and leave the training courses and experiences as it is.
I wonder how can I run this code in less than 1 hour.
Here is some rewrite on your code. The two primary differences are the use of If ... ElseIf ... End If and the grouping of the first and fourth conditional operations (the conditions were the same).
Sub Merge_Cells()
Dim lastRow As Long, rw As Long
Dim intUpper As Long, x As Long
Dim vVALs As Variant
appTGGL bTGGL:=False
Debug.Print Timer
With Worksheets("A")
.Cells(1, 1) = Timer
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For rw = 2 To lastRow
vVALs = Array(.Cells(rw - 1, 2).Value, .Cells(rw, 2).Value, .Cells(rw + 1, 2).Value)
If vVALs(1) <> vVALs(0) And vVALs(1) <> vVALs(2) Then
'the first and fourth conditions were the same so they are both here
'original first If condition
intUpper = rw
'Debug.Print ("<> -1 and <> +1 " & intUpper)
'original fourth If condition
'Debug.Print ("One Cells: " & rw)
.Range(.Cells(rw, 1), .Cells(rw, 26)).Borders(xlEdgeBottom).LineStyle = xlDouble
.Cells(intUpper, 14).Value = .Cells(intUpper, 13).Value
ElseIf vVALs(1) <> vVALs(0) And vVALs(1) = vVALs(2) Then
intUpper = rw
'Debug.Print ("<> -1 and = +1 " & intUpper & " UPPPER LIMIT")
ElseIf vVALs(1) = vVALs(0) And vVALs(1) <> vVALs(2) Then
'Debug.Print ("<> +1 and = -1:" & rw & "LOWER LIMIT")
For x = 1 To 26
If x < 9 Or x > 17 Then _
.Range(.Cells(intUpper, x), .Cells(rw, x)).Merge
Next x
.Cells(intUpper, 14).Value = "=sumif(M" & CStr(intUpper) & ":M" & CStr(rw) & ","">0"")"
.Range(.Cells(intUpper, 14), .Cells(rw, 14)).Merge
.Cells(rw, 1).Resize(1, 26).Borders(xlEdgeBottom).LineStyle = xlDouble
End If
Next rw
.Cells(1, 2) = Timer
End With
Debug.Print Timer
appTGGL
End Sub
Sub appTGGL(Optional bTGGL As Boolean = True)
Application.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
Application.ScreenUpdating = bTGGL
Application.EnableEvents = bTGGL
Application.DisplayAlerts = bTGGL
End Sub
I've also read the three primary conditional values into a variant array to reduce repeated worksheet value reads.

How do you speed up VBA code with a named range?

I have written a program that analyzes a worksheet (with 8000 rows and 40 columns) and returns all of the relevant product ID's but my program is unbearably slow, it takes about 5 minutes to run, so In looking for a way to speed it up I came across some code to disable screenupdating, display status bar, calculation, and events. which doubled the programs run time (from 5 to 10 minutes) But i need the program to be able to run faster still. I kept searching and came across This This seems like it's exactly what i need but i don't exactly understand how to implement it.
Let me explain what my code needs to do and maybe you can help me find a better way. It might be helpful to tell you what the information is about. I work for a company that sells holsters, and we are trying to find a way to gather all of the product ID's for different types of holsters for 1 gun together. So in the first column we have the Gun names, in the 4th column we have the Holster Type and in the 12th column we have the Product ID #.
What I'm trying to do is to for any given line, make the program look throught the rest of the file and return the product ID's for the matching products (products with the exact same name) in lines 33-39 i.e column 33 will have the related concealment holster, 34 will have the related ankle holster etc.
I have already written a code to do this but how can i do it with this named DataRange Method?
Do
ActiveCell.Offset(1, 0).Activate
Location = ActiveCell.Address
GunName = ActiveCell.Value
X = 0
Range("A1").Activate
Do
If ActiveCell.Offset(X, 0).Value = GunName Then
PlaceHolder = ActiveCell.Address
If ActiveCell.Offset(X, 3).Value = "CA" Then
Range(Location).Offset(0, 34).Value = ActiveCell.Offset(X, 12).Value
ElseIf ActiveCell.Offset(X, 3).Value = "AA" Or ActiveCell.Offset(X, 3).Value = "AR" Then
If ActiveCell.Offset(X, 4).Value = "NA-LH" Or ActiveCell.Offset(X, 4).Value = "NA" Or ActiveCell.Offset(X, 4).Value = "11-LH" Or ActiveCell.Offset(X, 4).Value = "13-LH" Or ActiveCell.Offset(X, 4).Value = "12-A-LH" Or ActiveCell.Offset(X, 4).Value = "12-B-LH" Or ActiveCell.Offset(X, 4).Value = "12-C-LH" Or ActiveCell.Offset(X, 4).Value = "12-JB-LH" Or ActiveCell.Offset(X, 4).Value = "12-LS-LH" Or ActiveCell.Offset(X, 4).Value = "12-LS-b-LH" Or ActiveCell.Offset(X, 4).Value = "11-LS-LH" Or ActiveCell.Offset(X, 4).Value = "21L" Then
Else
Range(Location).Offset(0, 35).Value = ActiveCell.Offset(X, 12)
End If
ElseIf ActiveCell.Offset(X, 3).Value = "BA" Or ActiveCell.Offset(X, 3).Value = "BR" Then
Range(Location).Offset(0, 36).Value = ActiveCell.Offset(X, 12)
ElseIf ActiveCell.Offset(X, 3).Value = "HA" Or ActiveCell.Offset(X, 3).Value = "HR" Then
Range(Location).Offset(0, 37).Value = ActiveCell.Offset(X, 12)
ElseIf ActiveCell.Offset(X, 3).Value = "VA" Or ActiveCell.Offset(X, 3).Value = "VR" Then
Range(Location).Offset(0, 38).Value = ActiveCell.Offset(X, 12)
ElseIf ActiveCell.Offset(X, 3).Value = "TA" Or ActiveCell.Offset(X, 3).Value = "TR" Then
Range(Location).Offset(0, 39).Value = ActiveCell.Offset(X, 12)
End If
End If
X = X + 1
Loop Until IsEmpty(ActiveCell.Offset(X, 0).Value)
ActiveCell.Range(Location).Activate
Loop Until IsEmpty(ActiveCell.Value)
AA, BA CA etc are the holster types.
EDIT
After viewing the sample file and clarifying through the below comments, here is the updated code. I believe this should work for you:
Sub tgr()
Dim rngData As Range
Dim GunCell As Range
Dim rngFound As Range
Dim arrResults() As Variant
Dim ResultIndex As Long
Dim cIndex As Long
Dim strFirst As String
Dim strTemp As String
On Error Resume Next
With Range("DataRange")
.Sort .Resize(, 1), xlAscending, Header:=xlYes
Set rngData = .Resize(, 1)
End With
On Error GoTo 0
If rngData Is Nothing Then Exit Sub 'No data or no named range "DataRange"
With rngData
ReDim arrResults(1 To .Rows.Count, 1 To 6)
For Each GunCell In .Cells
If GunCell.Row > 1 Then
ResultIndex = ResultIndex + 1
If LCase(GunCell.Text) <> strTemp Then
strTemp = LCase(GunCell.Text)
Set rngFound = .Find(strTemp, .Cells(.Cells.Count), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Do
If InStr(1, " CA BA HA VA TA ", " " & .Parent.Cells(rngFound.Row, "D").Text & " ", vbTextCompare) > 0 Then
Select Case UCase(.Parent.Cells(rngFound.Row, "D").Text)
Case "CA": cIndex = 1
Case "BA": cIndex = 3
Case "HA": cIndex = 4
Case "VA": cIndex = 5
Case "TA": cIndex = 6
End Select
arrResults(ResultIndex, cIndex) = .Parent.Cells(rngFound.Row, "M").Text
ElseIf InStr(1, " AA AR ", " " & .Parent.Cells(rngFound.Row, "D").Text & " ", vbTextCompare) > 0 _
And InStr(1, " NA-LH NA 11-LH 13-LH 12-A-LH 12-B-LH 12-C-LH 12-JB-LH 12-LS-LH 12-LS-b-LH 11-LS-LH 21L ", " " & .Parent.Cells(rngFound.Row, "E").Text & " ", vbTextCompare) = 0 Then
cIndex = 2
arrResults(ResultIndex, cIndex) = .Parent.Cells(rngFound.Row, "M").Text
End If
Set rngFound = .Find(strTemp, rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
End If
Else
For cIndex = 1 To UBound(arrResults, 2)
arrResults(ResultIndex, cIndex) = arrResults(ResultIndex - 1, cIndex)
Next cIndex
End If
End If
Next GunCell
End With
Range("AI2:AI" & Rows.Count).Resize(, UBound(arrResults, 2)).ClearContents
If ResultIndex > 0 Then Range("AI2").Resize(ResultIndex, UBound(arrResults, 2)).Value = arrResults
End Sub
Avoid .Activate, which is VERY slow and generally useless. Instead try something in this style:
Option Explicit
Sub sample()
Dim c As Range
For Each c In Range("a:a").SpecialCells(xlCellTypeConstants)
If c.Offset(x, 0).Value = GunName Then
'etc etc
End If
Next c
End Sub
Oh ! and make sure you use Option Explicit and you Dim your variables. It's not for speed, it is to avoid errors. And use comments ;-)