counter loop in Excel - vba

So I've got an Excel workbook with multiple worksheets. Each worksheet is the same template. And cells B3 - B39, C3 - C39, and D3 - D39 will contain 1 of 3 values. 1, .5, or no value at all (completely blank). Now each worksheet isn't exactly the same (some will go to B/C/D45 instead of just B/C/D39). I'm trying to have another cell show how many of those cells contain a 1, and another cell show how many contain a .5. Yeah I could manually do it, but I'm trying to get this as automated as possible.

As #Variatus has suggested, you could just use the COUNTIF worksheet function, but if you wanted to do this with VBA, what you need to do is:
Method
Identify the last row
Build the range
Count how many of the cells in this range contain 1
Count how many of the cells in this range contain .5
Do something with these counts
Code
Sub CountTheSheets()
Const Value10 As Double = 1, Value05 As Double = 0.5 ' these are what we're comparing cell values against
Dim Count10 As Long, Count05 As Long ' these are our 1 and .5 counts respectively
Dim lastRow As Long, lastRowTemp As Long, maxRow As Long
Dim ws As Worksheet
Dim cel As Range
For Each ws In ThisWorkbook.Worksheets ' iterate over all worksheets
lastRow = 0 ' reset the last row for this worksheet
Count10 = 0 ' reset the 1 count for this worksheet
Count05 = 0 ' reset the .5 count for this worksheet
With ws
maxRow = .Rows.Count ' this is the absolute bottom row in a worksheet
' get last row of column B, by going to the bottom of the worksheet in that column, then using End and going up to find the last cell
lastRowTemp = .Cells(maxRow, "B").End(xlUp).Row
If lastRowTemp > lastRow Then lastRow = lastRowTemp
' get last row of column C; if larger than the previous, store in lastRow that row number instead
lastRowTemp = .Cells(maxRow, "C").End(xlUp).Row
If lastRowTemp > lastRow Then lastRow = lastRowTemp
' get last row of column D; if larger than the previous, store in lastRow that row number instead
lastRowTemp = .Cells(maxRow, "D").End(xlUp).Row
If lastRowTemp > lastRow Then lastRow = lastRowTemp
' build the range using lastRow, and iterate through the cells in that range, counting the matching values
For Each cel In .Range("B3:D" & lastRow)
If cel.Value = Value10 Then
Count10 = Count10 + 1
ElseIf cel.Value = Value05 Then
Count05 = Count05 + 1
End If
Next cel
' do something with these counts
Debug.Print .Name, Count10, Count05
End With
Next ws
End Sub

Related

Iterate through matrix dynamically with filter

I have a matrix with lots of rows which do have different row lengths. As you can see in the image below, row 3 ends at column T, whereas row 8 ends at column L. What I am trying to do is to loop through every row of the matrix with the fleet name "Taxi" and sum up every entry.
How can I accomplish this? The main problem I face is with iterating through the rows and finding the end of the row dynamically and how to filter the table beforehand by the fleetname.
Code does what you want
Dim sht As Worksheet
Dim LastColumn As Long
Dim LastRow as Long
Dim i as Long
Dim dblSum as Double 'your sum
Set sht = ThisWorkbook.ActiveSheet
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i=2 to LastRow
If .Cells(i,1).Value = "Taxi" Then
LastColumn = .Cells(i, .Columns.Count).End(xlToLeft).Column
dblSum = Application.Sum(.Range(.Cells(i, 2), .Cells(i, LastColumn)))
End if
Next i
End with
Set sht = Nothing

Can not find last row on a separate worksheet in excel

I am currently working on a macro and I had it working 100% like I wanted, but when I went to move the control group to a different sheet, I've started getting all sorts of problems. Here is the code:
Sub Duplicate_Count()
'Diclare Variables
Dim LastRow As Long
Dim value1 As String
Dim value2 As String
Dim counter As Long
Dim startRange As Long
Dim endRange As Long
Dim inColumn As String
Dim outColumn As String
Dim color As Long
counter = 0
Dim sht As Worksheet
Dim controlSht As Worksheet
Set sht = Worksheets("Sheet1")
Set controlSht = Worksheets("Duplicate Check")
'Find the last used row in column L
LastRow = sht.Cells(Rows.Count, "L").End(xlUp).Row
'set default ranges
startRange = 2
endRange = LastRow - 1
inColumn = "L"
outColumn = "N"
'check for user inputs
If controlSht.Cells(8, "B") <> "" Then
startRange = controlSht.Cells(8, "B")
End If
If controlSht.Cells(8, "C") <> "" Then
endRange = controlSht.Cells(8, "C")
End If
If controlSht.Cells(11, "C") <> "" Then
Column = controlSht.Cells(11, "C")
End If
If controlSht.Cells(14, "C") <> "" Then
Column = controlSht.Cells(14, "C")
End If
color = controlSht.Cells(17, "C").Interior.color
'Search down row for duplicates
Dim i As Long
For i = startRange To endRange
'Sets value1 and value2 to be compared
value1 = sht.Cells(i, inColumn).Value
value2 = sht.Cells(i + 1, inColumn).Value
'If values are not diferent then counter will not increment
counter = 1
Do While value1 = value2
sht.Cells(i, inColumn).Interior.color = color
sht.Cells(i + counter, inColumn).Interior.color = color
counter = counter + 1
value2 = sht.Cells(i + counter, inColumn).Value
Loop
'Ouput the number of duplicates on last duplicates row
If counter <> 1 Then
sht.Cells(i + counter - 1, outColumn) = counter
i = i + counter - 1
End If
Next i
End Sub
This is my first program so I apologize for all the mistakes. This code does exactly what I want except for finding the last row if there is no user input. It always says the last row is 1, when it should be 110460. I'm not sure if it's grabbing from the wrong sheet or if there is an error in my logic.
This should be easy to fix by just Activating the sheet first. I can't recall the exact syntax but since you tagged this macros just record a macro, then select a sheet and click on it somewhere. Then open up the macro it will say something like Sheets("sheet name".Activate. Or Sheets("sheet name").Select. Repeat that for each worksheet you want to run the macro on. To clarify, each time your macro finds the last row on 1 sheet, then you Activate or Select the next worksheet and find the last row again. Suppose this is being called in a loop through list of worksheet names.
I changed the "L" to an 11, and it all seems to work now. Why it wants it this way i have no clue, but it works.
I always do it like this.
Sub FindingLastRow()
'PURPOSE: Different ways to find the last row number of a range
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'Using UsedRange
sht.UsedRange 'Refresh UsedRange
LastRow = sht.UsedRange.Rows(sht.UsedRange.Rows.Count).Row
'Using Table Range
LastRow = sht.ListObjects("Table1").Range.Rows.Count
'Using Named Range
LastRow = sht.Range("MyNamedRange").Rows.Count
'Ctrl + Shift + Down (Range should be first cell in data set)
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
End Sub
https://www.thespreadsheetguru.com/blog/2014/7/7/5-different-ways-to-find-the-last-row-or-last-column-using-vba

Remove all rows that contain value VBA

I've been working on this for longer than I'd like to admit. I'm comparing two Worksheets (A & B). I'm looping through A-Column("B") and for each value in that column I'm checking it against B-Column("C"). If there's a match, I want to delete the entire row.
I've done it a number of different ways and I just can't get it to work. This is the original:
Option Explicit
Sub Purge()
Dim wipWS As Worksheet
Dim invWS As Worksheet
Dim C As Range
Dim SourceLastRow As Long
Dim DestLastRow As Long
Dim LRow As Long
Dim D As Range
Set wipWS = Worksheets("Work in Process")
Set invWS = Worksheets("Inventory Allocation")
With wipWS
' find last row in Work in Process Column B
SourceLastRow = .Cells(.Rows.count, "E").End(xlUp).Row
' find last row in Inventory Allocation Column C
DestLastRow = invWS.Cells(invWS.Rows.count, "B").End(xlUp).Row
' define the searched range in "Inventory Allocation" sheet
Set C = invWS.Range("B1:B" & DestLastRow)
Set D = wipWS.Range("E1:E" & SourceLastRow)
' allways loop backwards when deleting rows or columns
' choose 1 of the 2 For loops below, according to where you want to delete
' the matching records
' --- according to PO request delete the row in Column B Sheet A
' and the row in Column C in "Inventory Allocation" worksheet
' I am looping until row 3 looking at the PO original code
For LRow = SourceLastRow To 1 Step -1
' found a match between Column B and Column C
If Not IsError(Application.Match(.Cells(LRow, "E"), C, 0)) Then
.Cells(LRow, 2).EntireRow.Delete Shift:=xlUp
invWS.Cells(Application.Match(.Cells(LRow, "E"), C, 0), 2).EntireRow.Delete Shift:=xlUp
End If
Next LRow
End With
End Sub
It works, except it leaves 1 row left (that should be deleted). I think I know why it's happening, except I have no idea of how to do it. I've tried a For loop and it works, except I have to set a range (eg., "A1:A200") and I want it to only loop through based on the number of rows.
Any help would be greatly appreciated!
Instead of running 2 loops, you can run 1 For loop in yout Worksheets("Work in Process"), scanning Column B, and then just use the Match function to search for that value in the entire C range - which is Set to Worksheets("Inventory Allocation") at Column C (untill last row that has data).
Note: when deleting rows, allways use a backward loop (For loop counting backwards).
Code
Option Explicit
Sub Purge()
Dim wipWS As Worksheet
Dim invWS As Worksheet
Dim C As Range
Dim SourceLastRow As Long
Dim DestLastRow As Long
Dim LRow As Long
Set wipWS = Worksheets("Work in Process")
Set invWS = Worksheets("Inventory Allocation")
With wipWS
' find last row in Sheet A Column B
SourceLastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
' find last row in Sheet B Column C
DestLastRow = invWS.Cells(invWS.Rows.Count, "C").End(xlUp).Row
' define the searched range in "Inventory Allocation" sheet
Set C = invWS.Range("C1:C" & DestLastRow)
' allways loop backwards when deleting rows or columns
' choose 1 of the 2 For loops below, according to where you want to delete
' the matching records
' --- according to PO request delete the row in Column B Sheet A
' and the row in Column C in "Inventory Allocation" worksheet
' I am looping until row 3 looking at the PO original code
For LRow = SourceLastRow To 3 Step -1
' found a match between Column B and Column C
If Not IsError(Application.Match(.Cells(LRow, "B"), C, 0)) Then
.Cells(LRow, 2).EntireRow.Delete Shift:=xlUp
invWS.Cells(Application.Match(.Cells(LRow, "B"), C, 0), 3).EntireRow.Delete Shift:=xlUp
End If
Next LRow
End With
End Sub
You are comparing two Worksheets (A & B). You want to loop through A-Column("B") and for each value in that column, check against B-Column("C").
So you can have a counter (ie. bRow) to keep track of which row you are looking at in worksheet B
Dim cell as Range
Dim bRow as Integer
bRow = 1
With Worksheets("A")
For Each cell in Range(.Range("B1"), .Range("B1").End(xlDown))
If (cell.Value = Worksheets("B").Range("C" & bRow).Value0 Then
cell.EntireRow.Delete Shift:=xlUp
Worksheets("B").Range("C" & bRow).EntireRow.Delete Shift:=xlUp
Else
bRow = bRow + 1
End If
Next cell
End WIth
So I finally figured this out. It's not pretty and I'm sure there is a more elegant way of doing this, but here it is.
Option Explicit
Public Sub purWIP()
Dim wipWS As Worksheet
Dim invWS As Worksheet
Dim P As Range
Dim i As Integer, x As Integer
Set wipWS = Worksheets("Work in Process")
Set invWS = Worksheets("Inventory Allocation")
' Start by checking conditions of a certain row
For x = wipWS.UsedRange.Rows.count To 1 Step -1
With wipWS
' For each cell in wipWS I'm going to check whether a certain condition exists
For Each P In wipWS.Range(.Cells(6, 5), .Cells(wipWS.Rows.count, 5).End(xlUp))
'If it does, then I'm going to check the Inventory Allocation Worksheet to see if there's a match
If (IsDate(P.Offset(0, 7))) Then
invWS.Activate
' I do a for loop here and add 1 to i (this was the part that fixed it)
For i = invWS.UsedRange.Rows.count + 1 To 3 Step -1
If invWS.Cells(i, "B") = P.Offset(0, 0) Then
invWS.Rows(i).EntireRow.Delete Shift:=xlUp
End If
Next
P.EntireRow.Delete Shift:=xlUp
End If
Next
End With
Next
wipWS.Activate
End Sub

VBA Delete all cells in each row except the last used cell

Trying to write a script to delete all cells in a row except the last used cell, then move all remaining data to the first column.
See below:
|--| is an empty cell
|XX| is a cell with unneeded data
|DATA| is the cell with Data I require.
Before:
|--|--|--|XX|XX|XX|XX|DATA|
|--|--|XX|XX|XX|DATA|
After
|DATA|
|DATA|
Assuming you meant in Excel:
Process:
Loop over the sheet
Set a tempVal variable to the value of the lastColumn
Loop through the columns to the last column for that row, clearing each cell
Set the value of column A to the tempVal
TESTED:
Sub GetLastColumnValue()
Dim lastRow As Long
Dim lastCol As Long
Dim sheet As String
Dim tempVal As String
sheet = "Sheet1"
lastRow = Sheets(sheet).Range("A" & Rows.Count).End(xlUp).row 'Using Range()
For lRow = 2 To lastRow
lastCol = Sheets(sheet).Cells(lRow, Columns.Count).End(xlToLeft).Column
tempVal = Sheets(sheet).Cells(lRow, lastCol).Text
For lCol = 1 To lastCol
Sheets(sheet).Cells(lRow, lCol).ClearContents
Next lCol
Sheets(sheet).Cells(lRow, 1) = tempVal
Next lRow
End Sub

Infinite loop while gathering datasets from several worksheets

This is my first time to code in VBA.
I have several worksheets in a file and they are in order by dates.
So what I am trying to do is to collect data sets in a worksheet if they have the same period of time.
date1 value1
date2 value2
date3 value3
Since they are in order I just compare the first date values and if they are different it moves on to the next worksheet. If they are the same then copy the value and do the same process until it reaches the last worksheet.
However it copies one worksheet fine but after that Excel freezes.
I would be appreciated if you find any errors or give me other suggestions to do it.
Following is my code:
Sub matchingStock()
Dim sh1 As Worksheet, sh2 As Worksheet
' create short references to sheets
' inside the Sheets() use either the tab number or name
Set sh1 = Sheets("combined")
Dim col As Long
'since first column is for Tbill it stock price should place from the third column
col = 3
Dim k As Long
'go through all the stock worksheets
For k = Sheets("WLT").Index To Sheets("ARNA").Index
Set sh2 = Sheets(k)
' Create iterators
Dim i As Long, j As Long
' Create last rows values for the columns you will be comparing
Dim lr1 As Long, lr2 As Long
' create a reference variable to the next available row
Dim nxtRow As Long
' Create ranges to easily reference data
Dim rng1 As Range, rng2 As Range
' Assign values to variables
lr1 = sh1.Range("A" & Rows.Count).End(xlUp).Row
lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
Application.ScreenUpdating = False
' Loop through column A on sheet1
For i = 2 To lr1
Set rng1 = sh1.Range("A" & i)
' Loop through column A on sheet1
For j = 2 To lr2
Set rng2 = sh2.Range("A" & j)
' compare the words in column a on sheet1 with the words in column on sheet2
'Dim date1 As Date
'Dim date2 As Date
'date1 = TimeValue(sh1.Range("A3"))
'date2 = TimeValue(sh2.Range("A3"))
sh1.Cells(1, col).Value = sh2.Range("A1").Value
' find next empty row
nxtRow = sh1.Cells(Rows.Count, col).End(xlUp).Row + 1
' copy the word in column A on sheet2 to the next available row in sheet1
' copy the value ( offset(0,1) Column B ) to the next available row in sheet1
sh1.Cells(nxtRow, col).Value = rng2.Offset(0, 6).Value
'when the date is different skip to the next worksheet
Set rng2 = Nothing
Next j
Set rng1 = Nothing
Next i
'sh3.Rows("1:1").Delete
Else
GoTo Skip
End If
Skip:
col = col + 1
Next k
End Sub
I cannot identify a specific error so this is a list of suggestions that may help you identify the error and may help improve your code.
Suggestion 1
Do you think the Else block of If-Then-Else-End-If is compulsory?
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
Else
GoTo Skip
End If
Skip:
is the same as:
If sh1.Range("A3").Value = sh2.Range("A3").Value Then
:
End If
Suggestion 2
I do not like:
For k = Sheets("WLT").Index To Sheets("ARNA").Index
The value of property Index for a worksheet may not what you think it is. This may not give you the set or sequence of worksheets you expect. Do you want every worksheet except "Combined"? The following should be more reliable:
For k = 1 To Worksheets.Count
If Worksheets(k).Name <> sh1.Name Then
:
End If
Next
Suggestion 3
You use:
.Range("A" & Rows.Count)
.Range("A3")
.Cells(1, col).Value
.Cells(Rows.Count, col)
rng2.Offset(0, 6)
All these methods of identifying a cell or a range have their purposes. However, I find it confusing to use more than one at a time. I find .Cells(row, column) and .Range(.Cells(row1, column1), .Cells(row2, column2)) to be the most versatile and use them unless there is a powerful reason to use one of the other methods.
Suggestion 4
I cannot decypher what this code is attempting to achieve.
You say: "I have several worksheets in a file and they are in order by dates. So what I am trying to do is to collect data sets in a worksheet if they have the same period of time."
If you have set Worksheet("combined").Range("A3").Value to a particular date and you want to collect data from all those sheets with the same value in cell A3 then the outer For-Loop and the If give this effect. But if so, if does not matter how the worksheets are ordered. Also you start checking cell values from row 2 which suggests row 3 is a regular data row.
The outer loop is for each worksheet, the next loop is for each row in "combined" and the inner loop is for each row in the worksheet selected by the outer loop. The middle loop does not appear to do anything but set rng1 which is not used.
Perhaps you can add an explanation of what you are trying to achieve.
Suggestion 5
Are you trying to add an entire column of values from the source worksheets to "Combined". The macro below:
Identifies the next free row in column A of "Combined"
Identifies the last used row in column A of "Sheet2"
Assumes the first interesting row of "Sheet2" is 2.
Adds the entire used range of column A of "Sheet2" (complete with formatting) to the end of "Combined"'s column A in a single statement.
This may demonstrate a better way of achieving the effect you seek.
Sub Test()
Dim RngSrc As Range
Dim RngDest As Range
Dim RowCombNext As Long
Dim RowSrcFirst As Long
Dim RowSrcLast As Long
With Worksheets("Combined")
RowCombNext = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Set RngDest = .Cells(RowCombNext, "A")
End With
With Worksheets("Sheet2")
RowSrcFirst = 2
RowSrcLast = .Cells(Rows.Count, "A").End(xlUp).Row
Set RngSrc = .Range(.Cells(RowSrcFirst, "A"), .Cells(RowSrcLast, "A"))
End With
RngSrc.Copy Destination:=RngDest
End Sub