This is one of those things that I'm sure there's a built-in function for (and I may well have been told it in the past), but I'm scratching my head to remember it.
How do I loop through each row of a multi-column range using Excel VBA? All the tutorials I've been searching up seem only to mention working through a one-dimensional range...
Dim a As Range, b As Range
Set a = Selection
For Each b In a.Rows
MsgBox b.Address
Next
Something like this:
Dim rng As Range
Dim row As Range
Dim cell As Range
Set rng = Range("A1:C2")
For Each row In rng.Rows
For Each cell in row.Cells
'Do Something
Next cell
Next row
Just stumbled upon this and thought I would suggest my solution. I typically like to use the built in functionality of assigning a range to an multi-dim array (I guess it's also the JS Programmer in me).
I frequently write code like this:
Sub arrayBuilder()
myarray = Range("A1:D4")
'unlike most VBA Arrays, this array doesn't need to be declared and will be automatically dimensioned
For i = 1 To UBound(myarray)
For j = 1 To UBound(myarray, 2)
Debug.Print (myarray(i, j))
Next j
Next i
End Sub
Assigning ranges to variables is a very powerful way to manipulate data in VBA.
In Loops, I always prefer to use the Cells class, using the R1C1 reference method, like this:
Cells(rr, col).Formula = ...
This allows me to quickly and easily loop over a Range of cells easily:
Dim r As Long
Dim c As Long
c = GetTargetColumn() ' Or you could just set this manually, like: c = 1
With Sheet1 ' <-- You should always qualify a range with a sheet!
For r = 1 To 10 ' Or 1 To (Ubound(MyListOfStuff) + 1)
' Here we're looping over all the cells in rows 1 to 10, in Column "c"
.Cells(r, c).Value = MyListOfStuff(r)
'---- or ----
'...to easily copy from one place to another (even with an offset of rows and columns)
.Cells(r, c).Value = Sheet2.Cells(r + 3, 17).Value
Next r
End With
Related
I am looking to search the text in first column for specific words and when they're found copy and paste the adjacent column to somewhere else.
I've got this code which works fine if the text is exactly those words but if anything else is there it fails (i.e super consolidator).
I'm still very new to VBA and have just adapted some other code to get to this point. I figure the find function would be a good way to go about it but I can't wrap my head around how to avoid the infinite loops. Any help here would be appreciated
Sub Test()
Dim lr As Long
Dim r As Long
' Find last row in column A with data
lr = Cells(Rows.Count, "A").End(xlUp).Row
' Loop through all rows in column A
For r = 1 To lr
' Check value on entry
If (Cells(r, "A") = "Super") Or (Cells(r, "A") = "Pension") Or (Cells(r, "A") = "SMSF") Then
' Copy column B and paste in C where found
Cells(r, "B").Select
Selection.Copy
ActiveCell.Offset(0, 1).PasteSpecial
End If
Next r
End Sub
What you're looking for is called Wildcard string comparision. And you can use VBA's Like operator to achieve your output
If (Cells(r, "A") Like "Super*") Or (Cells(r, "A") Like "Pension*") Or (Cells(r, "A") Like "SMSF*") Then
Here the * in Super* means that the text should start with "Super" and it can have anything after that.
If you'd like to search if the cell contains "Super" anywhere, you can use *Super* - * at both ends of Super
To have a more robust code I moved the "signal" words you are checking for into an array at the beginning of the sub.
Same with the column indexes of the column you want to copy and the target index.
By that it is much easier to make adjustments if the requirements change, e.g. look for a forth word etc.
Furthermore you should avoid implicit referencing cells. That's why I added the ws-variable - you have to adjust your sheet name.
Plus I added a generic function isInArray that takes the cell-value plus the array with the lookup values and returns true or false. Here the like-operator is implemented.
You don't need to select-copy/paste the values - you can simply write them to the target cell: .Cells(r, targetColumnIndex).value = .Cells(r, sourceColumnIndex).value.
But be aware: if you have a lot of data it would make more sense to load everything into an array and work on that ... but that's the next lesson to learn ;-)
Option Explicit
Public Sub copyValues()
Dim arrLookupValues(2) As Variant
arrLookupValues(0) = "Super"
arrLookupValues(1) = "Pension"
arrLookupValues(2) = "SMSF"
Const sourceColumnIndex As Long = 2 'take value from column B
Const targetColumnIndex As Long = 3 'write value to colum C
application.screenupdating = false
Dim lr As Long
Dim r As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'adjust this to your needs
With ws
lr = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = 1 To lr
' Check value on entry
If isInArray(.Cells(r, 1).value, arrLookupValues) Then
' write value of column B (2) to C (3)
.Cells(r, targetColumnIndex).value = .Cells(r, sourceColumnIndex).value
End If
Next r
End With
application.screenupdating = true
End Sub
Private Function isInArray(value As Variant, arrLookFor As Variant) As Boolean
Dim i As Long
For i = LBound(arrLookFor) To UBound(arrLookFor)
If value like arrLookFor(i) & "*" Then
isInArray = True
Exit For
End If
Next
End Function
i have found many very similar questions in the forum, but somehow nothing fits what i am looking for.
I have two ranges (a & b) which i'd like to compare and if values do not match, i'd like to copy the entire row to a predefined worksheet. The purpose is to find rows / values that have been changed vs. previous edit.
Dim a, b as range
Dim ws1,ws2,ws3 as worksheet
Dim last_row, last_row2 as integer 'assume last_row =15, last_row2=12
Dim i, j, k as integer
last_row=15
last_row2=12
' the orignal range is not massive, but at 500x 6 not small either
Set a=ws1.range("I5:S"& last_row)
Set b=ws2.range("H2:R"& last_row2)
I have seen different approaches when it comes to addressing each item of the range and don't know which would be quickest / best (loop or for each ).
The main if-statement would look something like this:
'assume i, j are the used as counters running across the range
k = 1
If Not a(i).value=b(j).value then
a(i)EntireRow.copy
ws3.row(k).paste
k = k + 1
end if
The solution cannot be formula based, as I need to have ws3 saved after each comparison.
Any help on this is much appreciated. Thanks!
If you have the ability to leverage Excel Spill Ranges, you can achieve what you want without VBA. Here's a web Excel file that shows all rows in first sheet where column A does not equal column b.
=FILTER(Sheet1!A:ZZ,Sheet1!A:A<>Sheet1!B:B)
If VBA is required, this routine should work. It's not optimal for handling values (doesn't use an array), but it gets it done.
Sub listDifferences()
Dim pullWS As Worksheet, pushWS As Worksheet
Set pullWS = Sheets("Sheet1")
Set pushWS = Sheets("Sheet2")
Dim aCell As Range
For Each aCell In Intersect(pullWS.Range("A:A"), pullWS.UsedRange).Cells
If aCell.Value <> aCell.Offset(0, 1).Value Then
Dim lastRow As Long
lastRow = pushWS.Cells(Rows.Count, 1).End(xlUp).Row
pushWS.Rows(lastRow + 1).Value = aCell.EntireRow.Value
End If
Next aCell
End Sub
This is the small for-loop I ended up using.
Thanks for your input!
For i = 1 To rOutput.Cells.Count
If Not rOutput.Cells(i) = rBackUp.Cells(i) Then
' Debug.Print range1.Cells(i)
' Debug.Print range2.Cells(i)
rOutput.Cells(i).EntireRow.Copy wsChangeLog.Rows(k)
k = k + 1
End If
Next i
Edit: This question has been re-worked to provide better clarity of my problem.
There's 2 factors to my question.
First Factor: I have a validation list in a sheet called "Admin Sheet". In that list are 'Tasks'.
I would like to cross reference those tasks in the "list", against those contained in a range (rangeString) taken from another sheet and count the number of 'Occurrences' for each item.
i.e. Task 1 appears 3 times, Task 2 appears 1 time, etc etc..
Factor 2: For each item within the list I would also like to gather the number of 'Hours' spent on that task.
For example:
Task 1 may appear 3 times on 3 different rows within the range. On each row in another column are the hours spent on that particular task. I would like to 'Sum' those hours from the 3 rows and I'd like to do this for all the 'Tasks'.
Note: The range is variable and will change daily.
Note: The columns that contain the info are: 'F' - Tasks and 'K' for Hours.
My current attempt at just capturing 'one' Task and its Hours associated with it:
Dim PaintWWArray() As Variant
Dim PHoursCnt As Long
Set srchRng = ActiveSheet.Range(rangeString)
Set rngfindValue = srchRng.find(what:="AD PAINTING W/W", Lookat:=xlPart)
'Find all the Tasks and Hours
If Not rngfindValue Is Nothing Then
rngFirstAddress = rngfindValue.Address
Do
PaintWWCnt = PaintWWCnt + 1
PHoursCnt = rngfindValue.Offset(0, 4).Value
ReDim Preserve PaintWWArray(PHoursCnt)
PaintWWArray(PHoursCnt) = PHoursCnt
Set rngfindValue = srchRng.FindNext(rngfindValue)
Loop Until rngfindValue Is Nothing Or rngfindValue.Address = rngFirstAddress
PWWSum = Application.WorksheetFunction.Sum(PaintWWArray)
MsgBox PWWSum
End If
Once I have collected the number of 'Occurrences' for each Task and the Sum of the hours for each task, I want to pass them into another sheet.
Worksheets("Weekly Data").Range("C6").Value = PaintWWCnt
Worksheets("Weekly Data").Range("D6").Value = PWWSum
I hope this is clearer...
I would suggest using a Dictionary.
Assuming you want to count all words:
Dim myDict
Set myDict = CreateObject("Scripting.Dictionary")
' Go through the array
For Each addDuty In arr
' If you only want to count specific words, add in IF statement here
myDict(addDuty) = myDict(addDuty) + 1
Next addDuty
If you only want to count words in an exiting set, it becomes slightly more elaborate.
It's not entirely clear what you want to achieve but the code below should give you the data you need. It's very fast. Please try it.
Private Sub STO_Answer()
' 024
' this procedure requires a reference to be set to
' Microsoft Scripting Runtime
Dim Counter As Scripting.Dictionary ' store task names and their count
Dim Arr As Variant ' an array of the data in Rng
Dim CellVal As Variant ' temporary storage of each cell value
Dim R As Long ' row counter
Dim Key As Variant ' a dictionary Key
Arr = ActiveSheet.Range("C2:D27").Value ' change to name the sheet
' adjust the range to suit
Set Counter = New Scripting.Dictionary
With Counter
For R = 1 To UBound(Arr) ' loop through all rows
AddToCounter Arr(R, 1), Counter ' first column of cell range
AddToCounter Arr(R, 2), Counter ' second column of cell range
Next R
For Each Key In Counter.Keys
Debug.Print Key, Counter.Item(Key)
Next Key
End With
End Sub
Private Sub AddToCounter(CellVal As Variant, _
Counter As Scripting.Dictionary)
' 024
With Counter
If .Exists(CellVal) Then
.Item(CellVal) = .Item(CellVal) + 1
Else
.Add CellVal, 1
End If
End With
End Sub
A Dictionary is a data structure which holds two related values. Here it's used to hold the task name and the number of times it occurs. Make sure you enable the reference to Microsoft Scripting Runtime in Tools > References. You don't specify if there is any relationship- between the tasks in the first column and the second. The above code counts both independently for now.
The result is printed to the Immediate Window. Of course, you might use this result in any other way in your code. Your question doesn't cover your intentions.
You won't be able to escape from the necessity to present your count in some way forever. As it turns out, there is only one efficient way to do it. This one:-
All duties are in column A and all added duties are in row 2.
Of course, you might use rather elaborate VBA to do the counting but Excel has a better way using a worksheet function. In order to set up COUNTIF() to work I created two named ranges as follows.
["Duties"] =OFFSET(Sheet2!$C$2,0,0,COUNTA(Sheet2!$C:$C)-1)
and
["AddDuties"] =OFFSET(Duties,0,1)
Sheet2!$C$2 is where my data started. Replace with the first cell of the first column of your data range. COUNTA(Sheet2!$C:$C)-1 makes this range dynamic. The function counts how many entries there are in that same column, -1 because the count would include a caption (modify if you have more or fewer headers).
AddDuties is simply defined as "same as Duties" but removed by one column to the right. You could move it elsewhere. As you add or delete rows in the column of Duties, AddDuties expands or contracts right along.
Now the formula in B3 is shown below. It's copied down and across as required. Please observe the $ signs.
[B3] =COUNTIFS(Duties,$A3,AddDuties,B$2)
This will probably generate a lot of zeroes. It did in my example and I didn't like them. Therefore I formatted B3 with the Custom cell format 0;; before copying to the other cells, which hides them.
Now this list would automatically update as you make entries in your data. You will never have to run code and the list will always be ready.
Finally, one recommendation. All your added duties, like "AD PAINITNG H/R", are hard to type correctly. Therefore the user should select them from a validation drop-down when entering them in the data. Most probably, you already have a list somewhere which feeds such drop-downs. The captions in the count list must be taken from the same source. But that creates redundancy. The better way is to make the list in B2:H2 of the count list the "original". Name the range and make it dynamic and you will never have to think about this subject again.
i think a better approach would be to use for each loops, this way you won't have to hardcode the conditions via IfElse. If you have the values in column A of a sheet and wants to go through those values and get their adjacent value in column B, you can use For Each looping to go through each values defined in A to get B.
just to add, regarding on counting of occurrence, you can define a counter that would add up for each occurrence of a unique value in column A.
I do not have time to wait for clarifications I asked... I prepared a piece of code, starting from the assumption that your strings to be counted are in column "F:F", and the value to be calculated is in column "K:K". The processing result is dropped on the last available column of the active pages, starting from row 2. If you prefer some relevant headers for the two involved columns, this can be easily automated. I used "Tasks and "Time...
It is able to deal with as many 'task' strings you will have in the future.
I commented the code lines, where I thought you do not understand what they do:
Sub CountOccurrencesAndValues()
Dim sh As Worksheet, rngF As Range, arrOcc As Variant, lastRow As Long, lastCol As Long
Dim arr As Variant, arrFin As Variant, countI As Long, valH As Double, j As Long, k As Long, i As Long
Set sh = ActiveSheet
lastRow = sh.Range("F" & Rows.count).End(xlUp).Row
lastCol = sh.UsedRange.Columns.count + 1
Set rngF = sh.Range("F2:F" & lastRow) 'the range where from to extract the unique values
arr = sh.Range("F2:K" & lastRow) 'the array to be processed
'Extract the unique values. Use for that a not used column:
rngF.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sh.Cells(1, lastCol), Unique:=True
'Put the unique values (sttrings) in an array:
arrOcc = sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).value
'Clear the temporary used array:
sh.Range(sh.Cells(1, lastCol), sh.Cells(sh.Cells(Rows.count, lastCol).End(xlUp).Row, lastCol)).Clear
ReDim arrFin(1 To UBound(arrOcc, 1), 1 To 3)
k = 1
'Processing the range by iteration:
For i = 1 To UBound(arrOcc, 1)
For j = 1 To UBound(arr, 1)
If arr(j, 1) = arrOcc(i, 1) Then
'count the occurrences and the value
countI = countI + 1: valH = valH + arr(j, 6)
End If
Next j
'put the data in the final array
arrFin(k, 1) = arrOcc(i, 1): arrFin(k, 2) = countI: arrFin(k, 3) = valH
countI = 0: valH = 0: k = k + 1
Next i
'Drop the data from array in the last available column:
'sh.Cells(1, lastCol).value = "Tasks": sh.Cells(1, lastCol + 1).value = "Count": sh.Cells(1, lastCol + 2).value = "Time"
'sh.Cells(2, lastCol).Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
Dim ws As Worksheet
Set ws = Worksheets("Weekly Data")
'Drop the data from array in "Weekly Data" worksheet:
ws.Range("C6").value = "Tasks": ws.Range("D6").value = "Count": ws.Range("E6").value = "Time"
ws.Range("C7").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).value = arrFin
End Sub
I have a sheet with about 6000 rows. In my code I first filter out some rows.
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=26, Criteria1:=">=2020-01-30 09:00:00", Operator:=xlAnd, Criteria2:="<=2020-01-30 09:30:00"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=24, Criteria1:="<>OK"
Sheets("privata").Rows("2:" & Rows.count).AutoFilter Field:=25, Criteria1:="<>SUPPLY_CONTROL,"
Its now down to about 350 rows. After I've filtered it I copy and paste the data to another sheet
Sheets("privata").UsedRange.Copy
Sheets("toptre").Range("A1").PasteSpecial xlPasteAll
After I've copied the data I work on it in various ways in the new sheet.
The entire code takes a while to run. After stepping through the code I discovered that the filtering out process is super quick. What takes time is the pasting of the data in to the other sheet.
Is there a possibility to work with the original filtered sheet? When I try to, it uses all 6000 rows, not just the filtered out ones.
Example of what I want to do:
For i = 2 To RowCount + 1
employee = Sheets("privata").Cells(i, 25)
onList = False
For j = 1 To UBound(employeeList)
If employee = employeeList(j) Then
onList = True
Exit For
End If
Next j
If onList = False Then
countEmployees = countEmployees + 1
employeeList(countEmployees) = employee
End If
If onList = True Then
onList = False
End If
Next i
When referring to Cells(2, 25) I want to refer to the second row in the filtered sheet. Which might be row 3568 in the sheet. Is that possible?
/Jens
After the filtering has been applied, you can make the copy/paste process very fast if you don't use a loop, but use Selection. For example:
Sub TryThis()
Dim r As Range
Sheets("privata").Select
Set r = ActiveSheet.AutoFilter.Range
r.Select
Selection.Copy Sheets("toptre").Range("A1")
End Sub
Usually you want to avoid Selection in VBA. However, you will end up with:
a block of data in sheet "toptre"
the block will include the header row and all visible rows
the block will be just a block (un-filtered)
I am not sure if this will make your process any faster, but it attempts to accomplish what you ask about in your question:
You could use the expression suggested by #GSerg 's comment to create a range object with only the visible rows in the data sheet, e.g.
Dim filteredRange As Range
Set filteredRange = Sheets("privata").UsedRange.Rows.SpecialCells(xlCellTypeVisible)
Assuming there is at least 1 visible row in the sheet (meaning that the above statement will not throw an error), you could then use the following function to access that range as if it were a single, contiguous range:
Function RelativeCell(rng As Range, ByVal row As Long, ByVal col As Long) As Range
Dim areaNum As Long: areaNum = 0
Dim maxRow As Long: maxRow = 0
Dim areaCount As Long: areaCount = rng.Areas.Count
Do While maxRow < row
areaNum = areaNum + 1
If areaNum > areaCount Then
Set RelativeCell = Nothing
Exit Function
End If
maxRow = maxRow + rng.Areas(areaNum).Rows.Count
Loop
Dim lastArea As Range: Set lastArea = rng.Areas(areaNum)
Set RelativeCell = lastArea.Cells(row - (maxRow - lastArea.Rows.Count), col)
End Function
To print all the filtered values in column B, for example, you could use the above method on the filteredRange object (set earlier) this way:
Dim r As Long: r = 1
Do
Dim cell As Range: Set cell = RelativeCell(filteredRange, r, 2)
If cell Is Nothing Then Exit Do
Debug.Print cell.Value
r = r + 1
Loop
To simplify the above code, you could also use a function to know the last relative row number in the filtered range using the following function:
Function RelativeCellLastRow(rng As Range) As Long
Dim r As Long: r = 0
Dim i As Long
For i = 1 To rng.Areas.Count
r = r + rng.Areas(i).Rows.Count
Next
RelativeCellLastRow = r
End Function
Then, the code to print all the filtered values in column B would be reduced to this:
Dim r As Long
For r = 1 To RelativeCellLastRow(filteredRange)
Debug.Print RelativeCell(testRng, r, 2).Value
Next
If you use RelativeCellLastRow, it would be good to ensure that it is only executed once, to avoid unnecessary recalculations. In the For loop above, it is only executed once, since VBA only executes the limits of a For loop before the first iteration. If you need the value several times, you can store it in a variable and use the variable instead.
The idea behind the RelativeCell function is that the range returned by the call to SpecialCells is a multi-area range, i.e. a range made up of several non-contiguous ranges. What relativeCell does is to skip through the non-contiguous areas until it finds the row number it is looking for. If the row number is beyond the total number of rows in the range, the function returns Nothing, so the calling code must be aware of this to avoid calling a method or property on Nothing.
It is also worth nothing that RelativeCell works on a range with hidden rows, not hidden columns. With hidden columns, the code becomes a little more complex, but the complexity can be encapsulated in the RelativeCell function without affecting the code that uses the function.
Again, I am not sure whether this will make your code faster. When I did some tests to emulate your scenario using a sheet with 6000+ rows and 30 columns of random strings, the copy/paste after the filtering ran very quickly, but it could be because of the machine I am using, the version of Excel that I am using (2016), or the data I used. Having said that, I hope the above code is of some help.
Ideally, I would have a range selected and then I would run the macro and I want the macro to essentially run a loop to go through each row so I can extract information from each row until it reaches the end of the range.
For example, A6:B9 are selected, first I want to focus on A6:B6. As in I want to be able to find the min value of the two cells for instance, using my MinSelected function(stated below) which requires a selected range which would ideally be A6:B6. And I want to do this for each row until the end of the original range.
Function MinSelected(R As Range)
MinSelected = Application.WorksheetFunction.min(R)
End Function
Is there any way to do this??? Please tell me to clarify anything that's unclear. Thanks in advance.
You can loop through rows - but looping through a variant array is more efficient (for many rows)
variant aray
Dim X
Dim lngCnt As Long
X = Range("A6:B9").Value2
For lngCnt = 1 To UBound(X)
Debug.Print Application.Min(Application.Index(X, lngCnt))
Next
range approach
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Range("A6:B9")
For Each rng2 In rng1.Rows
Debug.Print Application.Min(rng2)
Next
Use a For loop, Rows.Count property, Columns.Count
Dim i as long
For i = 1 to Selection.Rows.Count
For j = 1 To Selection.Columns.Count
Cells(i, j).Value ' Use this to access the value of cell in row i and column j