I am trying to refactor a part of a project that I am working on I have Two blocks of code that pretty much do the same thing except with a single variable changed (rowNum_partNum, 1) and (rowNum, 2) in the other block. I can not split the two into separate functions as they both use a variable that is highly manipulated within the current function. I tried refactoring but I cant figure out what's wrong.
Original Code that works:
If PartNumber_Category_Selector() <> 0 Then
If PartNumber_Category_Selector() = 1 Then
Dim rowNum_partNum As Long
Dim searchRow_PartNum As Long
rowNum_partNum = 9
searchRow_PartNum = 9
Worksheets("DataBase").Activate
Do Until Cells(rowNum_partNum, 1).Value = ""
If InStr(1, Cells(rowNum_partNum, 1).Value, searchingItem, vbTextCompare) > 0 Then
Worksheets("LeadTimes").Cells(searchRow_PartNum, 1).Value = Cells(rowNum_partNum, 1).Value
Worksheets("LeadTimes").Cells(searchRow_PartNum, 2).Value = Cells(rowNum_partNum, 2).Value
Worksheets("LeadTimes").Cells(searchRow_PartNum, 3).Value = Cells(rowNum_partNum, 3).Value
Worksheets("LeadTimes").Cells(searchRow_PartNum, 4).Value = Cells(rowNum_partNum, 4).Value
searchRow_PartNum = searchRow_PartNum + 1
End If
rowNum_partNum = rowNum_partNum + 1
Loop
If searchRow_PartNum = 9 Then
MsgBox "No Results found"
Else
lst_leadTime.RowSource = "SearchResultsV5"
End If
ElseIf PartNumber_Category_Selector() = 2 Then
Dim rowNum As Long
Dim searchRow As Long
rowNum = 9
searchRow = 9
Worksheets("DataBase").Activate
Do Until Cells(rowNum, 1).Value = ""
If InStr(1, Cells(rowNum, 2).Value, searchingItem, vbTextCompare) > 0 Then
Worksheets("LeadTimes").Cells(searchRow, 1).Value = Cells(rowNum, 1).Value
Worksheets("LeadTimes").Cells(searchRow, 2).Value = Cells(rowNum, 2).Value
Worksheets("LeadTimes").Cells(searchRow, 3).Value = Cells(rowNum, 3).Value
Worksheets("LeadTimes").Cells(searchRow, 4).Value = Cells(rowNum, 4).Value
searchRow = searchRow + 1
End If
rowNum = rowNum + 1
Loop
If searchRow = 9 Then
MsgBox "No Results found "
Else
lst_leadTime.RowSource = "SearchResultsV5"
End If
Else
MsgBox "No Results found "
End If
Else
MsgBox "No Results found "
End If
Refactored code (Does not work):
If PartNumber_Category_Selector() <> 0 Then
Dim rowNum_partNum As Long, searchRow_PartNum As Long, Selector As Byte
rowNum_partNum = 9
searchRow_PartNum = 9
Selector = PartNumber_Category_Selector()
Worksheets("DataBase").Activate
Do Until Cells(rowNum_partNum, Selector).Value = ""
If InStr(1, Cells(rowNum_partNum, Selector).Value, searchingItem, vbTextCompare) > 0 Then
Worksheets("LeadTimes").Cells(searchRow_PartNum, 1).Value = Cells(rowNum_partNum, 1).Value
Worksheets("LeadTimes").Cells(searchRow_PartNum, 2).Value = Cells(rowNum_partNum, 2).Value
Worksheets("LeadTimes").Cells(searchRow_PartNum, 3).Value = Cells(rowNum_partNum, 3).Value
Worksheets("LeadTimes").Cells(searchRow_PartNum, 4).Value = Cells(rowNum_partNum, 4).Value
searchRow_PartNum = searchRow_PartNum + 1
End If
rowNum_partNum = rowNum_partNum + 1
Loop
If searchRow = 9 Then
MsgBox "No Results found "
Else
lst_leadTime.RowSource = "SearchResultsV5"
End If
End IF
Related
I'm sure I've just made a school boy error but i just can't see it :(
I have a user form that searches a worksheet(sheet 2) and displays the results in a list box but the code will only work when excel is visible and the sheet being searched selected. Any advice would be greatly received :)
Private Sub Branch_Search_Button_Click()
'branch search
Dim rownum As Long
Dim searchrow As Long
Sheet5.Range("A2:C9999").ClearContents
rownum = 2
searchrow = 2
Do Until Sheet2.Cells(rownum, 1).Value = ""
If InStr(1, Sheet2.Cells(rownum, 2).Value, TextBox1.Value, vbTextCompare) > 0 Then
Sheet5.Cells(searchrow, 1).Value = Cells(rownum, 1).Value
Sheet5.Cells(searchrow, 2).Value = Cells(rownum, 2).Value
Sheet5.Cells(searchrow, 3).Value = Cells(rownum, 3).Value
searchrow = searchrow + 1
End If
rownum = rownum + 1
Loop
If searchrow = 2 Then
MsgBox "Area not found"
Exit Sub
End If
ListBox2.RowSource = "Area_Search!a1:c" & Range("c" & Rows.Count).End(xlDown).Row
End Sub
That was it! thanks for your help Super Symmetry really appreciated!!! :D
Potential solution
You should fully qualify all your ranges. The following might fix your error. Please note the comments starting with '*
Private Sub Branch_Search_Button_Click()
'branch search
Dim rownum As Long
Dim searchrow As Long
Sheet5.Range("A2:C9999").ClearContents
rownum = 2
searchrow = 2
Do Until Sheet2.Cells(rownum, 1).Value = ""
If InStr(1, Sheet2.Cells(rownum, 2).Value, TextBox1.Value, vbTextCompare) > 0 Then
'* Change Sheet2 to the appropriate sheet code
Sheet5.Cells(searchrow, 1).Value = Sheet2.Cells(rownum, 1).Value
Sheet5.Cells(searchrow, 2).Value = Sheet2.Cells(rownum, 2).Value
Sheet5.Cells(searchrow, 3).Value = Sheet2.Cells(rownum, 3).Value
searchrow = searchrow + 1
End If
rownum = rownum + 1
Loop
If searchrow = 2 Then
MsgBox "Area not found"
Exit Sub
End If
'* change Sheet5 to the appropriate sheet code
ListBox2.RowSource = "Area_Search!a1:c" & Sheet5.Range("c" & Rows.Count).End(xlDown).Row
End Sub
Pic 2 shows what the solution should be and Pic 1 shows what my code has given me, the differences occur in the "Yearly Change","Percent Change" and "Total Stock Volume" columns.
The loop I created works for all the sheets but my figures in those specified column are off, can I get help in rectifying my code attached to get numbers similar to Pic 2? Thank you
Option Explicit
Sub Stockmarket()
'Declare and set worksheet
Dim ws As Worksheet
'Loop through all stocks for one year
For Each ws In Worksheets
'Create the column headings
ws.Range("I1").Value = "Ticker"
ws.Range("J1").Value = "Yearly Change"
ws.Range("K1").Value = "Percent Change"
ws.Range("L1").Value = "Total Stock Volume"
ws.Range("P1").Value = "Ticker"
ws.Range("Q1").Value = "Value"
ws.Range("O2").Value = "Greatest % Increase"
ws.Range("O3").Value = "Greatest % Decrease"
ws.Range("O4").Value = "Greatest Total Volume"
'Define Ticker variable
Dim Ticker As String
'Set initial and last row for worksheet
Dim Lastrow As Long
Dim i As Long
Dim j As Integer
Dim x As Double
j = 2
x = 2
'Define Lastrow of worksheet
Lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
'Set new variables for prices and percent changes
Dim open_price As Double
'open_price = 0
Dim close_price As Double
'close_price = 0
Dim price_change As Double
'price_change = 0
Dim price_change_percent As Double
'price_change_percent = 0
'Create variable to keep the ticker row in
Dim TickerRow As Long
TickerRow = 1
Dim stock_volume As Double
stock_volume = 0
'Do loop of current worksheet to Lastrow
For i = 2 To Lastrow
'Ticker symbol output
If ws.Cells(i + 1, 1).Value <> ws.Cells(i, 1).Value Then
TickerRow = TickerRow + 1
Ticker = ws.Cells(i, 1).Value
ws.Cells(TickerRow, "I").Value = Ticker
'Stock Volume output
If ws.Cells(i, 1).Value = ws.Cells(i + 1, 1).Value Then
stock_volume = stock_volume + ws.Cells(i, 7).Value
ElseIf ws.Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
stock_volume = stock_volume + ws.Cells(i, 7).Value
ws.Cells(j, 9).Value = ws.Cells(i, 1).Value
ws.Cells(j, 12).Value = stock_volume
j = j + 1
stock_volume = 0
End If
'Creating the Yearly change and Percent change output
open_price = ws.Cells(i, 3).Value
close_price = ws.Cells(i, 6).Value
ws.Cells(x, 10).Value = open_price - close_price
If close_price <= 0 Then
ws.Cells(x, 11).Value = 0
Else
ws.Cells(x, 11).Value = (close_price / open_price) - 1
End If
ws.Cells(x, 11).Style = "Percent"
If ws.Cells(x, 10).Value >= 0 Then
ws.Cells(x, 10).Interior.ColorIndex = 4
Else
ws.Cells(x, 10).Interior.ColorIndex = 3
End If
x = x + 1
ws.Cells(x, 9).Value = ws.Cells(i, 1).Value
ws.Cells(x, 10).Value = close_price - open_price
If close_price <= 0 Then
ws.Cells(x, 11).Value = 0
Else
ws.Cells(x, 11).Value = (close_price / open_price) - 1
End If
ws.Cells(x, 11).Style = "Percent"
If ws.Cells(x, 10).Value >= 0 Then
ws.Cells(x, 10).Interior.ColorIndex = 4
Else
ws.Cells(x, 10).Interior.ColorIndex = 3
End If
End If
Next i
Next ws
End Sub
You seem to have a logic problem - see the two marked lines below
'Ticker symbol output
If ws.Cells(i + 1, 1).Value <> ws.Cells(i, 1).Value Then '<<<<<<<<<
TickerRow = TickerRow + 1
Ticker = ws.Cells(i, 1).Value
ws.Cells(TickerRow, "I").Value = Ticker
'Stock Volume output
If ws.Cells(i, 1).Value = ws.Cells(i + 1, 1).Value Then '<<< never true!
stock_volume = stock_volume + ws.Cells(i, 7).Value
ElseIf ws.Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
stock_volume = stock_volume + ws.Cells(i, 7).Value
ws.Cells(j, 9).Value = ws.Cells(i, 1).Value
ws.Cells(j, 12).Value = stock_volume
j = j + 1
stock_volume = 0
End If
How I can refer to Worksheets("Customers") without activating the worksheet in the below code?
Application.ScreenUpdating does not do the job, as there is still annoying flickering.
The code is working fine when I uncomment 'Worksheets("Customers").Activate
I want to perform all steps when Worksheets("Dashboard") is open.
I have tried "With ... End With" but no luck., also referencing Worksheets("Customers").Cells..... etc are not working. Its like code skipping through the code and goes straight to
"
If SearchRow = 2 Then
MsgBox "Customer Not Found", vbExclamation
Exit Sub
End If
"
I also have another code similar issue, that for some reason referencing not working as it should.
Just want to mention that I am using this code with the userforms and click buttons.
Any help will be appreciated.
Private Sub srCus_Click()
Application.ScreenUpdating = False
Dim RowNum As Long
Dim SearchRow As Long
RowNum = 2
SearchRow = 2
Worksheets("SearchCus").Range("A2:I100").ClearContents
'Worksheets("Customers").Activate
Do Until Worksheets("Customers").Cells(RowNum, 1).Value = ""
If InStr(1, Cells(RowNum, 3).Value, CusDB.Value, vbTextCompare) > 0 Then
Worksheets("SearchCus").Cells(SearchRow, 1).Value = Cells(RowNum, 1).Value
Worksheets("SearchCus").Cells(SearchRow, 2).Value = Cells(RowNum, 2).Value
Worksheets("SearchCus").Cells(SearchRow, 3).Value = Cells(RowNum, 3).Value
Worksheets("SearchCus").Cells(SearchRow, 4).Value = Cells(RowNum, 4).Value
Worksheets("SearchCus").Cells(SearchRow, 5).Value = Cells(RowNum, 5).Value
Worksheets("SearchCus").Cells(SearchRow, 6).Value = Cells(RowNum, 6).Value
Worksheets("SearchCus").Cells(SearchRow, 7).Value = Cells(RowNum, 7).Value
Worksheets("SearchCus").Cells(SearchRow, 8).Value = Cells(RowNum, 8).Value
Worksheets("SearchCus").Cells(SearchRow, 9).Value = Cells(RowNum, 9).Value
SearchRow = SearchRow + 1
End If
RowNum = RowNum + 1
Loop
If SearchRow = 2 Then
MsgBox "Customer Not Found", vbExclamation
Exit Sub
End If
ResultsDB.RowSource = "SearchResults"
'ThisWorkbook.Worksheets("Dashboard").Activate
Application.ScreenUpdating = True
End Sub
Thanks SJR, You were right with reference to all these Cells(RowNum, 1), I was always skipping one with InStr line. Thanks for the help and all suggestions. Reviewed code below.
Private Sub srCus_Click()
Application.ScreenUpdating = False
Dim RowNum As Long
Dim SearchRow As Long
RowNum = 2
SearchRow = 2
Worksheets("SearchCus").Range("A2:I100").ClearContents
'Worksheets("Customers").Activate
Do Until Worksheets("Customers").Cells(RowNum, 1).Value = ""
If InStr(1, Worksheets("Customers").Cells(RowNum, 3).Value, CusDB.Value, vbTextCompare) > 0 Then
Worksheets("SearchCus").Cells(SearchRow, 1).Value = Worksheets("Customers").Cells(RowNum, 1).Value
Worksheets("SearchCus").Cells(SearchRow, 2).Value = Worksheets("Customers").Cells(RowNum, 2).Value
Worksheets("SearchCus").Cells(SearchRow, 3).Value = Worksheets("Customers").Cells(RowNum, 3).Value
Worksheets("SearchCus").Cells(SearchRow, 4).Value = Worksheets("Customers").Cells(RowNum, 4).Value
Worksheets("SearchCus").Cells(SearchRow, 5).Value = Worksheets("Customers").Cells(RowNum, 5).Value
Worksheets("SearchCus").Cells(SearchRow, 6).Value = Worksheets("Customers").Cells(RowNum, 6).Value
Worksheets("SearchCus").Cells(SearchRow, 7).Value = Worksheets("Customers").Cells(RowNum, 7).Value
Worksheets("SearchCus").Cells(SearchRow, 8).Value = Worksheets("Customers").Cells(RowNum, 8).Value
Worksheets("SearchCus").Cells(SearchRow, 9).Value = Worksheets("Customers").Cells(RowNum, 9).Value
SearchRow = SearchRow + 1
End If
RowNum = RowNum + 1
Loop
If SearchRow = 2 Then
MsgBox "Customer Not Found", vbExclamation
Exit Sub
End If
ResultsDB.RowSource = "SearchResults"
'ThisWorkbook.Worksheets("Dashboard").Activate
Application.ScreenUpdating = True
End Sub
I'm trying to find all rows in a single column with the same value. The program should delete all rows that occur multiple times, apart from one of the columns, which should contract all statements from the deleted rows. This is what I have so far, but I'm getting a loop error:
Sub tester()
Sheets("Sheet1").Select
Dim one As Integer
one = 2
Dim log As Integer
log = 2
Dim compare As Integer
compare = one + 1
Dim ws As String
ws = "Sheet1"
Dim ender As String
ender = "Sheet4"
Dim counter As Integer
counter = 0
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).row
For log = 2 To lastrow - 1
one = log + counter
compare = one + 1
If Worksheets(ws).Cells(one, 1).Value = Worksheets(ws).Cells(compare,1).Value And Worksheets(ws).Cells(one, 7).Value = Worksheets(ws).Cells(compare, 7).Value Then
Do While Worksheets(ws).Cells(one, 1).Value = Worksheets(ws).Cells(compare, 1).Value And Worksheets(ws).Cells(one, 7).Value = Worksheets(ws).Cells(compare, 7).Value
If compare = one + 1 Then
Worksheets(ender).Cells(log, 1).Value = Worksheets(ws).Cells(one, 1).Value
Worksheets(ender).Cells(log, 4).Value = Worksheets(ws).Cells(one, 4).Value
Worksheets(ender).Cells(log, 2).Value = Worksheets(ws).Cells(one, 2).Value
Worksheets(ender).Cells(log, 7).Value = Worksheets(ws).Cells(one, 7).Value
End If
Worksheets(ender).Cells(log, 4).Value = Worksheets(ender).Cells(log, 4).Value & "; " & Worksheets(ws).Cells(compare, 4).Value
compare = compare + 1
counter = counter + 1
Loop
ElseIf Worksheets(ws).Cells(one, 1).Value <> Worksheets(ws).Cells(compare, 1).Value Then
Worksheets(ender).Cells(one - counter, 1).Value = Worksheets(ws).Cells(one, 1).Value
Worksheets(ender).Cells(one - counter, 2).Value = Worksheets(ws).Cells(one, 2).Value
Worksheets(ender).Cells(one - counter, 3).Value = Worksheets(ws).Cells(one, 3).Value
Worksheets(ender).Cells(one - counter, 4).Value = Worksheets(ws).Cells(one, 4).Value
Worksheets(ender).Cells(one - counter, 5).Value = Worksheets(ws).Cells(one, 5).Value
Worksheets(ender).Cells(one - counter, 7).Value = Worksheets(ws).Cells(one, 7).Value
End If
Next log
Sheets("Sheet4").Select
End Sub
Original Data
Desired output
This code doesn't print -1 and 0 when it's supposed,
but everything else works fine.
It iterates through both lists: (Sheet1 and edi_partnere)
and exits loops when it's supposed.
Q: What am I missing: why isn't cells().value catching?
Do
If orgnr1 = "" Then Exit Sub
Do
orgnr2 = Sheets("edi_partnere").Cells(j, 1).Value
If orgnr2 = orgnr1 Then
Sheets("Sheet1").Cells(j, 9).Value = "-1" 'not happening
Exit Do
ElseIf orgnr2 = "" Then
Sheets("Sheet1").Cells(j, 9).Value = "0" 'not happening
Exit Do
Else: j = j + 1
End If
Loop
i = i + 1
orgnr1 = Sheets("Sheet1").Cells(i, 1).Value
Loop
I think that you must reset the variable j, so I add j = 0 in your code.
According to Siddharth Rout if orgnr1 not set then orgnr1 = Sheets("Sheet1").Cells(i, 1).Value
Do
If orgnr1 = "" Then Exit Sub
Do
orgnr2 = Sheets("edi_partnere").Cells(j, 1).Value
If orgnr2 = orgnr1 Then
Sheets("Sheet1").Cells(j, 9).Value = "-1" 'not happening
Exit Do
ElseIf orgnr2 = "" Then
Sheets("Sheet1").Cells(j, 9).Value = "0" 'not happening
Exit Do
Else: j = j + 1
End If
Loop
j = 0
i = i + 1
orgnr1 = Sheets("Sheet1").Cells(i, 1).Value
Loop