I want to group the employees by Emp Code. It works if there is more than 1 record for an employee but if there is < 1 it doesn't work. Like line 13 and 14. This should have been seperate
I have this code:
Dim counter As Integer
Dim customernumber As Integer
counter = 2
customernumber = 2
Do While Worksheets("Mini").Cells(counter, 1).Value <> ""
Worksheets("Mini").Cells(counter, 4).Value = "Testing the Do While"
Worksheets("Mini").Cells(counter, 5).Value = customernumber + 1
If Worksheets("Mini").Cells(counter, 1).Value <> z Then
z = Worksheets("Mini").Cells(counter + 1, 1).Value
With Worksheets("Mini").rows(counter - 1).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
Worksheets("Mini").Cells(counter, 5).Value = 1
customernumber = 0
End With
End If
How can I change it?
Below is a image of the sheet
You need to set z before the IF test.
Dim counter As Integer
Dim customernumber As Integer
Dim wks As Worksheet
Dim z As Long
Set wks = Worksheets("Mini")
counter = 2
customernumber = 2
With wks
Do While .Cells(counter, 1).Value <> ""
.Cells(counter, 4).Value = "Testing the Do While"
.Cells(counter, 5).Value = customernumber + 1
z = .Cells(counter + 1, 1).Value
If .Cells(counter, 1).Value <> z Then
With .rows(counter - 1).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
wks.Cells(counter, 5).Value = 1
customernumber = 0
End With
End If
counter = counter + 1
Loop
Related
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
Hello Everyone. I'm new to VBA and I keep getting an error that says "Compile error:
For without Next"
Sub Aplhabetical_Testing()
Dim ws As Worksheet
Dim ticker As String
Dim vol As Integer
Dim year_open As Double
Dim year_close As Double
Dim yearly_change As Double
Dim percent_change As Double
Dim total_stock_volume As Double
For Each ws In Worksheet
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"
For i = 2 To RowCount
j = 0
total = 0
Change = 0
Start = 2
If Cells(i + 1, 1).Value <> Cells(i, 7).Value Then
total = total + Cells(i, 7).Value
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = 0
Range("K" & 2 + j).Value = "%" & 0
Range("L" & 2 + j).Value = 0
Else
If Cells(Start, 3) = 0 Then
For find_value = Start To i
If Cells(find_value, 3).Value <> 0 Then
Start = find_value
Exit For
End If
Next find_value
End If
Change = (Cells(i, 6) - Cells(Start, 3))
percentChange = Round((Change / Cells(Start, 3) * 100), 2)
Start = i + 1
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = Round(Change, 2)
Range("K" & 2 + j).Value = "%" & percentChange
Range("L" & 2 + j).Value = total
Select Case Change
Case Is > 0
Range("j" & 2 + j).Interior.ColorIndex = 4
Case Is < 0
Range("j" & 2 + j).Interior.ColorIndex = 3
Case Else
Range("j" & 2 + j).Interior.ColorIndex = 0
End Select
End If
End Sub
There are a number of statements in VBA which must be properly terminated. For instance,
Sub / End Sub,
Function / End Function,
If / End If.
With / End With, or
Enum / End Enum
For better code readability everything between the statement and the End should be indented, like this:-
Sub MySub()
' Here is my code
End Sub
or
If 1 < 2 Then
' Here is what to do in that case
End If
For / Next and Do / Loop work exactly the same way. For example,
For i = 1 to 10
' code to be executed *i* times
Next i
The concepts can be nested. Here's an example.
Private Sub MySub()
Dim i As Integer
For i = 1 to 10
If i = 5 then
Debug.Print "Half done"
End if
Next i
End Sub
You miss two Next:
Sub Aplhabetical_Testing()
Dim ws As Worksheet
Dim ticker As String
Dim vol As Integer
Dim year_open As Double
Dim year_close As Double
Dim yearly_change As Double
Dim percent_change As Double
Dim total_stock_volume As Double
For Each ws In Worksheet ' Worksheets?
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"
For i = 2 To RowCount
j = 0
total = 0
Change = 0
Start = 2
If Cells(i + 1, 1).Value <> Cells(i, 7).Value Then
total = total + Cells(i, 7).Value
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = 0
Range("K" & 2 + j).Value = "%" & 0
Range("L" & 2 + j).Value = 0
Else
If Cells(Start, 3) = 0 Then
For find_value = Start To i
If Cells(find_value, 3).Value <> 0 Then
Start = find_value
Exit For
End If
Next find_value
End If
Change = (Cells(i, 6) - Cells(Start, 3))
percentChange = Round((Change / Cells(Start, 3) * 100), 2)
Start = i + 1
Range("I" & 2 + j).Value = Cells(i, 1).Value
Range("j" & 2 + j).Value = Round(Change, 2)
Range("K" & 2 + j).Value = "%" & percentChange
Range("L" & 2 + j).Value = total
Select Case Change
Case Is > 0
Range("j" & 2 + j).Interior.ColorIndex = 4
Case Is < 0
Range("j" & 2 + j).Interior.ColorIndex = 3
Case Else
Range("j" & 2 + j).Interior.ColorIndex = 0
End Select
End If
' Missing Next
Next
' Missing Next
Next
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
I'm trying to loop through multiselected list of listbox in excel. but it throws Error "Next without For"
UserForm connects three books. Firstдн, macro should check for matches in book "ToolsDır". If there is a tool, then transfer it from responsible to recipient. then enter this transaction in "TOOLSJOURNAL". and go through all the selected elements of the list box doing the same action. I hope I could explain the problem
Private Sub cmbOK_Click()
Dim wbd, wbs As String
wbd = "...\TOOLS\TOOLSJOURNAL.xlsm"
wbs = "...\TOOLS\TOOLSDIR.xlsm"
If Trim(Me.cboCity.Value) = "" Or Trim(Me.cboReciever.Value) = "" Then
Me.TextDate.SetFocus
MsgBox ("Tool is already in use!")
Else
GetObject (wbs)
Dim lnItem As Long
For lnItem = 0 To Me.ListBox.ListCount - 1
If Me.ListBox.Selected(lnItem) Then
Dim ws As Worksheet
Set ws = Workbooks("TOOLSDIR").Worksheets("TABLE")
Dim rn1, rn2, rn3 As Range
Set rn1 = ws.Range("ID")
Set rn2 = ws.Range("EMPLOYEES")
Set rn3 = ws.Range("DATA")
Dim i, j, k, l As Integer
i = Application.Match(Me.ListBox.Selected(lnItem), ws.Range("ID"), 0)
j = Application.Match(Me.cboRespName.Value, ws.Range("EMPLOYEES"), 0)
k = Application.Match(Me.cboRecName.Value, ws.Range("EMPLOYEES"), 0)
l = rn3.Cells(i, j)
If rn3.Cells(i, j).Value <> 1 Then
MsgBox ("Fill Blank ")
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (False)
Else: rn3.Cells(i, j) = rn3.Cells(i, j) - 1
rn3.Cells(i, k) = rn3.Cells(i, k) + 1
End If
Application.DisplayAlerts = False
Workbooks("TOOLSDIR").Close (True)
With GetObject(wbd)
Dim Database As Worksheet
Set Database = Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL")
Dim NextRow As Long
NextRow = Database.Cells(Database.Rows.Count, 3).End(xlUp).Offset(1, 0).Row
If Database.Range("B4").Value = "" And Database.Range("C4").Value = "" Then
NextRow = NextRow - 1
End If
Database.Cells(NextRow, 3).Value = Me.TextDate.Value
Database.Cells(NextRow, 4).Value = Me.TextPurchaseDate
Database.Cells(NextRow, 5).Value = Me.TextFirstDate.Value
Database.Cells(NextRow, 6).Value = Me.TextDayTotal.Value
Database.Cells(NextRow, 7).Value = Me.cboRegion.Value
Database.Cells(NextRow, 8).Value = Me.cboCity.Value
Database.Cells(NextRow, 9).Value = Me.cboResponsible.Value
Database.Cells(NextRow, 10).Value = Me.cboRespName
Database.Cells(NextRow, 11).Value = Me.ListBox.List(lnItem, 1).Value
Database.Cells(NextRow, 12).Value = Me.ListBox.List(lnItem, 2).Value
Database.Cells(NextRow, 13).Value = Me.ListBox.List(lnItem, 3).Value
Database.Cells(NextRow, 14).Value = Me.cboReciever.Value
Database.Cells(NextRow, 15).Value = Me.cboRecName.Value
Database.Range("B4").Formula = "=If(ISBLANK(C4), """", COUNTA($C$4:C4))"
If NextRow > 4 Then
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Activate
Workbooks("TOOLSJOURNAL").Worksheets("JOURNAL").Range("B4").Select
Selection.AutoFill Destination:=Range("b4:b" & NextRow)
Range("b4:b" & NextRow).Select
End If
End With
Application.DisplayAlerts = False
Workbooks("TOOLSJOURNAL").Close (True)
Next lnItem
End If
Call resetForm
End Sub
i had input like below
1 10
2 20
3 30
1 40
2 50
4 60
1 80
and output , if had multiple matches corresponding value should be like below.
1 10 40 80
2 20 50
3 30
4 60
A1:B7
1 10
2 20
3 30
1 40
2 50
4 60
1 80
Sub copyit()
Dim LastRow As Long
Dim myRange, MyRange1 As Range
LastRow = Cells(Rows.count, "A").End(xlUp).Row
For X = 1 To LastRow
For Y = 1 + X To LastRow
If Cells(X, 1).Value = Cells(Y, 1).Value Then
If MyRange1 Is Nothing Then
Set MyRange1 = Rows(Y).EntireRow
Rows(X).End(xlToRight).Offset(, 1).Value = Cells(Y, 2).Value
Else
Set MyRange1 = Union(MyRange1, Rows(Y).EntireRow)
Rows(X).End(xlToRight).Offset(, 1).Value = Cells(Y, 2).Value
End If
End If
Next
Next
MyRange1.Select
Selection.Delete
End Sub
OR . . .
Sub ConcatData()
Dim X As Double
Dim DataArray(5000, 2) As Variant
Dim NbrFound As Double
Dim Y As Double
Dim Found As Integer
Dim NewWks As Worksheet
Cells(1, 1).Select
Let X = ActiveCell.Row
Do While True
If Len(Cells(X, 1).Value) = Empty Then
Exit Do
End If
If NbrFound = 0 Then
NbrFound = 1
DataArray(1, 1) = Cells(X, 1)
DataArray(1, 2) = Cells(X, 2)
Else
For Y = 1 To NbrFound
Found = 0
If DataArray(Y, 1) = Cells(X, 1).Value Then
DataArray(Y, 2) = DataArray(Y, 2) & ", " & Cells(X, 2)
Found = 1
Exit For
End If
Next
If Found = 0 Then
NbrFound = NbrFound + 1
DataArray(NbrFound, 1) = Cells(X, 1).Value
DataArray(NbrFound, 2) = Cells(X, 2).Value
End If
End If
X = X + 1
Loop
Set NewWks = Worksheets.Add
NewWks.Name = "SummarizedData"
Cells(1, 1).Value = "Names"
Cells(1, 2).Value = "Results"
X = 2
For Y = 1 To NbrFound
Cells(X, 1).Value = DataArray(Y, 1)
Cells(X, 2).Value = DataArray(Y, 2)
X = X + 1
Next
Beep
MsgBox ("Summary is done!")
End Sub