I want to VBA loop and highlight transactions (rows) where the bought and sold date entered in the same row are identical. The scenario is determining a percentage of day trades in a list of investments. Seems simple, but I can't find a search syntax that doesn't send me somewhere else.
Simple example code to your problem. Hope you will be able to modify it so suit your needs
Sub test()
Dim Sheet1 As Worksheet
Dim bought_range As Range
Dim bought_cell As Object
Dim sold_cell As Object
Set Sheet1 = ThisWorkbook.Worksheets(1)
Set bought_range = Sheet1.Range("B4:B20")
For i = 1 To bought_range.Rows.Count Step 1
Set bought_cell = bought_range.Cells(i, 1)
Set sold_cell = bought_range.Cells(i, 2)
If sold_cell.Value = bought_cell.Value Then
bought_cell.Interior.Color = RGB(0, 255, 0)
sold_cell.Interior.Color = RGB(0, 255, 0)
End If
Next i
End Sub
Related
Suppose I have the following table with three columns. I want to search for an exact match or next previous date from Column3, conditional to Column1 being a given value.
This can be easily done with XLOOKUP. However, I need to do so in VBA because I'll show the date found in a userform Textbox to the user. From what I have searched so far, Application.Worksheetfunction.Xlookup won't work with an & for multiple criteria, so the solution for this would involve manipulating arrays.
I created a variant from that table by writing:
Dim TBL As ListObject
Set TBL = Sheets("sheet1").ListObjects("Table1")
Dim DirArray As Variant
DirArray = TBL.DataBodyRange
Any advice on how to get that approximate match using arrays?
Using an array of values will be faster than referencing a cell for each check - esp. if your table is much larger.
You can use this function - it will return 0 in case no valid date is found.
As I am using sortBy you will need Excel 365 for this to work.
By using SortBy it is safe to exit the for-loop in case we have found a matching date.
Public Function nearestDate(lo As ListObject, valueColumn1 As String, valueColumn3 As Date) As Date
Dim arrValues As Variant
arrValues = Application.WorksheetFunction.SortBy(lo.DataBodyRange, lo.ListColumns(1).DataBodyRange, 1, lo.ListColumns(3).DataBodyRange, 1)
Dim i As Long
For i = 1 To UBound(arrValues, 1)
If arrValues(i, 1) = valueColumn1 Then
If arrValues(i, 3) = valueColumn3 Then
'we found what we are looking for
nearestDate = arrValues(i, 3)
ElseIf arrValues(i, 3) < valueColumn3 Then
'we have to check next row - if there is one
If i < UBound(arrValues, 1) Then
If arrValues(i + 1, 1) = valueColumn1 And arrValues(i + 1, 3) > valueColumn3 Then
'same column1 but column3 greater than valueColumn3
nearestDate = arrValues(i, 3)
ElseIf arrValues(i + 1, 1) <> valueColumn1 Then
'new column1 value --> therefore we take current date
nearestDate = arrValues(i, 3)
End If
Else
'last value --> ok
nearestDate = arrValues(i, 3)
End If
End If
End If
If nearestDate > 0 Then Exit For
Next
End Function
You can call this function like this:
Public Sub test()
Dim ws As Worksheet: Set ws = Thisworkbook.Worksheets("sheet1")
Dim lo As ListObject: Set lo = ws.ListObjects("Table1")
Dim valueColumn1 As String: valueColumn1 = ws.Range("F1")
Dim valueColumn3 As Date: valueColumn3 = ws.Range("F2")
Debug.Print nearestDate(lo, valueColumn1, valueColumn3)
End Sub
There may well be a neater answer, but here is a simple brute-force function that just scans down every row in the given data looking for the closest match to the given criteria. The function returns the date of the closest match, but maybe it would be more useful to you if it returned, say, the row number of the row that is the closest match. Put this function in a new code module so that it can be called as a function from a cell, for example =findEntryByCol1andCol3(Table1,F1,F2)
Option Explicit
Public Function findEntryByCol1andCol3(dataToSearch As Range, findCol1, findCol3) As Variant
'// variable to hold the row with the closest match to criteria
Dim matchRow As Range
Set matchRow = Nothing
'// variable to hold the row being checked
Dim checkRow As Range
Dim ix As Long
For ix = 1 To dataToSearch.Rows.Count
'// get the next row to be checked
Set checkRow = dataToSearch.Rows(ix)
'// does column 1 in this row match the search criterion for column 1?
If checkRow.Cells(1, 1).Value = findCol1 Then
'// now see if the date in the row is less than the search date
If findCol3 >= checkRow.Cells(1, 3).Value Then
'// If there has been no match then use this checked row as the first found match
If matchRow Is Nothing Then
Set matchRow = checkRow
'// If there has been a previous match check
'// if the new date is later that the previously found date
ElseIf matchRow.Cells(1, 3).Value < checkRow.Cells(1, 3).Value Then
Set matchRow = checkRow
End If
End If
Else
End If
Next ix
'// Now return the result of the search
If matchRow Is Nothing Then
findEntryByCol1andCol3 = "Not found"
Else
findEntryByCol1andCol3 = matchRow.Cells(1, 3)
End If
End Function
I have Sheet1.ComboBox1 that I would like to fill with an array of values. This array is stored on Sheet2. This array is a list of all customers to be used in the excel file. All customers are listed in one single column.
Some customers appear more than once in the column. It varies by how many part numbers a customer has.
I would like to fill a Sheet1.ComboBox1 with this array, however, I don't want duplicate values.
I read online that I can convert the array into a collection which will automatically weed out duplicates.
I would like to take this collection and input it into the Sheet1.ComboBox1, however, upon some research, I've found that collections are read-only...(am I wrong in this conclusion?)
One strategy I saw was to convert the customer array into a collection and then back into a new simplified array. The hope is to store this new array into Sheet 3, then pull this array into ComboBox1.List. I've posted my code below of this attempt.
'Converts collection to an accessible array
Function collectionToArray(c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.item(i)
Next
collectionToArray = a
End Function
Sub PopulateComboBoxes()
Dim ComboBoxArray As New Collection, customer
Dim CustomerArray() As Variant
Dim newarray() As Variant
Dim i As Long
CustomerArray() = Sheet2.Range("A5:A2000")
On Error Resume Next
For Each customer In CustomerArray
ComboBoxArray.Add customer, customer
Next
newarray = collectionToArray(ComboBoxArray)
Sheet3.Range("A1:A2000") = newarray
Sheet1.ComboBox1.List = Sheet3.Range("A1:2000")
I used ' CustomerArray() = Sheet2.Range("A5:2000") ' not because there are that many rows full of values in Sheet 2, rather, that I cover all bases when more customers are eventually added to the list. The total size of my Sheet 2 is currently A1:A110, but I want to future proof it.
When I run the code, the Array is successfully reduced and the new array is placed into Sheet3 with no duplicates. However, the first Customer entry is repeated after the last unique customer value is defined. (A46 is last unique customer, A47:A2000 its the same customer repeated)
Additionally, Sheet1.ComboBox1 remains empty.
Is anyone able to explain how to restrict the number of rows filled by 'collectionToArray' , instead of filling all 2000?
Also, where am I going wrong with filling the ComboBox1? Am I missing a command/function to cause the box to fill?
You don't need that function to make a New Array, seems Excessive to me.
Assigning to CustomerArray will take care of Future Additions in column
You can directly pass on the Collection value to ComboBox
You are missing On Error Goto 0 in your code after addition to Collection. That is making all to errors after that invisible and hard for you to identify which part of code is causing problems.
Here Try this:
Sub PopulateComboBoxes()
Dim ComboBoxArray As New Collection
Dim CustomerArray() As Variant
Dim newarray() As Variant
Dim i As Long
With Worksheets("Sheet2")
CustomerArray = .Range("A5:A" & .Range("A5").End(xlDown).row).Value
End With
On Error Resume Next
For i = LBound(CustomerArray) To UBound(CustomerArray)
ComboBoxArray.Add CustomerArray(i, 1), CustomerArray(i, 1)
Next
On Error GoTo 0
For Each Itm In ComboBoxArray
Worksheets("Sheet1").ComboBox1.AddItem Itm
Next
End Sub
First, you should assign your range dynamically to CustomerArray...
With Sheet2
CustomerArray() = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
Then, you should disable error handling after you've finished adding the items to your collection. Since you did not do so, it hid the fact that your range reference in assigning the values to your listbox was incorrect, and that you didn't use the Value property to assign them. So you should disable the error handling...
On Error Resume Next
For Each customer In CustomerArray
ComboBoxArray.Add customer, customer
Next
On Error GoTo 0
Then, when transferring newarray to your worksheet, you'll need to transpose the array...
Sheet3.Range("A1").Resize(UBound(newarray) + 1).Value = Application.Transpose(newarray)
Then, as already mentioned, you should assign the items to your listbox with Sheet3.Range("A1:A2000").Value. However, since newarray already contains a list of the items, you can simply assign newarray to your listbox...
Sheet1.ComboBox1.List = newarray
So the complete code would be as follows...
Sub PopulateComboBoxes()
Dim ComboBoxArray As New Collection, customer As Variant
Dim CustomerArray() As Variant
Dim newarray() As Variant
With Sheet2
CustomerArray() = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
On Error Resume Next
For Each customer In CustomerArray
ComboBoxArray.Add customer, customer
Next
On Error GoTo 0
newarray = collectionToArray(ComboBoxArray)
Sheet3.Range("A1").Resize(UBound(newarray) + 1).Value = Application.Transpose(newarray)
Sheet1.ComboBox1.List = newarray
End Sub
it could be achieved in a number of ways. using collection or dictionary object. i am just presenting simple method without going through collection or dictionary since only 5000 rows is to be processed. it could be further shortened if used directly with combo box without using OutArr. As #Domenic already answered it with explanations, may please go along with that solution.
Option Explicit
Sub test()
Dim InArr As Variant, OutArr() As Variant
Dim i As Long, j As Long, Cnt As Long
Dim have As Boolean
InArr = ThisWorkbook.Sheets("sheet2").Range("A5:A2000")
ReDim OutArr(1 To 1)
Cnt = 0
For i = 1 To UBound(InArr, 1)
If InArr(i, 1) <> "" Then
have = False
For j = 1 To UBound(OutArr, 1)
If OutArr(j) = InArr(i, 1) Then
have = True
Exit For
End If
Next j
If have = False Then
Cnt = Cnt + 1
ReDim Preserve OutArr(1 To Cnt)
OutArr(Cnt) = InArr(i, 1)
End If
End If
Next i
Sheet3.Range("A1").Resize(UBound(OutArr)).Value = Application.Transpose(OutArr)
Sheet1.ComboBox1.Clear
Sheet1.ComboBox1.List = OutArr
Debug.Print Sheet1.ComboBox1.ListCount
End Sub
What I am trying to accomplish is this:
If any cells in columns AC-AF in my entire worksheet are blank, cut the entire row and paste to a new worksheet labeled "MissingShipping".
Code should adjust with the amount of rows, since that will never be the same.
From examples I have seen I don't understand where to insert the range of the cells I want to wade through.
I get the error
"Method 'Range' of object'_Worksheet'
on the line NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, lastcolumn)).Select.
Option Explicit
Sub Shipping()
Dim MissingShipping As Worksheet
Set MissingShipping = Sheets.Add(After:=Sheets(Sheets.Count))
MissingShipping.Name = "MissingShipping"
Dim NewSetup As Worksheet
Dim lastcolumn As Integer
Dim Destinationrow As Integer
Dim lastrow As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
Destinationrow = 1
lastcolumn = NewSetup.Range("XFD1").End(xlToLeft).Column
lastrow = NewSetup.Range("A1048576").End(xlUp).Row
Dim i As Long
Dim j As Long
For i = lastrow To 1 Step -1
For j = 1 To lastcolumn
If NewSetup.Cells(i, j).Value = "" Then
NewSetup.Activate
NewSetup.Range(Cells(i, 1), Cells(i, lastcolumn)).Cut
MissingShipping.Activate
NewSetup.Range(Cells(Destinationrow, 1), Cells(Destinationrow, _
lastcolumn)).Select
ActiveSheet.Paste
NewSetup.Rows(i).Delete shift:=xlUp
Destinationrow = Destinationrow + 1
Exit For
End If
Next j
Next i
End Sub
G'day Nikki,
Welcome to the world of VBA! There are plenty of great resources on the internet to help you on your journey.
It's often easier and faster to work with a range inside your code instead of reading and writing to a sheet and selecting cells to mimic things that you would normally do if you were doing the job manually.
It's a good idea to get your head around the range object early on. It's handy for working with multiple worksheets.
The following is a good start with Ranges in Excel:
https://excelmacromastery.com/excel-vba-range-cells/
Another handy thing is a collection. If you had to store a bunch of things to work with later on, you can add them to a collection then iterate over them using a "For Each" loop. This is a good explanation of collections:
https://excelmacromastery.com/excel-vba-collections/
I had a quick look at your code and using the concept of Ranges and Collections, I have altered it to do what I think you were trying to do. I had to make a few assumptions as I haven't seen you sheet. I ran the code on a bunch of random rows on my computer to make sure it works. Consider the following:
Dim MissingShipping As Worksheet
Dim NewSetup As Worksheet
Dim rangeToCheck As Range
Dim cellsToCheck As Range
Dim targetRange As Range
Dim rw As Range 'rw is a row
Dim cl As Range 'cl is a cell
Dim rowColl As New Collection
Dim i As Long
Set NewSetup = Worksheets("NKItemBuildInfoResults")
Set MissingShipping = Worksheets("MissingShipping")
'Get the range of data to check
Set rangeToCheck = NewSetup.Range("A1").CurrentRegion
'For each row in the range
For Each rw In rangeToCheck.Rows
'For the last four cells in that row
Set cellsToCheck = rw.Cells(1, 29).Resize(1, 4)
For Each cl In cellsToCheck.Cells
'If the cell is empty
If cl.Value = "" Then
'Add the row to our collection of rows
rowColl.Add rw
'Exit the for loop because we only want to add the row once.
'There may be multiple empty cells.
Exit For
End If
'Check the next cell
Next cl
Next rw
'Now we have a collection of rows that meet the requirements that you were after
'Using the size collection of rows we made, we now know the size of the range
'we need to store the values
'We can set the size of the new range using rowColl.Count
'(that's the number of rows we have)
Set targetRange = MissingShipping.Range("A1").Resize(rowColl.Count, 32)
'Use i to step through the rows of our new range
i = 1
'For each row in our collection of rows
For Each rw In rowColl
'Use i to set the correct row in our target range an make it's value
'equal to the row we're looking at
targetRange.Rows(i) = rw.Value
'Increment i for next time
i = i + 1
Next rw
End Sub
Good luck! Hope this helps.
I would like some help with a problem, which I imagine requires some VBA. I would like to transfer data from one table to another, based on a cell value that you can define.
Please refer to the image above for the description of the problem.
I would like to be able to 'store' the score data from each corresponding Team from the table on the right, to the table on the left depending on the week selected.
E.g. Team 2 has a score of 10 in Week 1, therefore, when I click the STORE button, I would like to store it in its corresponding spot on the table on the left. However for all teams.
If I understood your question correctly then the following code will loop through the TeamIDs and Scores and place them in the correct Week Number on the other table:
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
Dim FoundID As Range, FoundID2 As Range
Dim TeamID As String, TeamID2 As String
Dim Score As String, Score2 As String
WeekNumber = ws.Range("M3").Value
'get WeekNumber to use for Offset
For i = 5 To 13
TeamID = ws.Cells(i, 13)
Score = ws.Cells(i, 15)
TeamID2 = ws.Cells(i, 18)
Score2 = ws.Cells(i, 16)
Set FoundID = ws.Range("B3:B21").Find(What:=TeamID)
If Not FoundID Is Nothing Then
FoundID.Offset(0, WeekNumber).Value = Score
End If
Set FoundID2 = ws.Range("B3:B21").Find(What:=TeamID2)
If Not FoundID2 Is Nothing Then
FoundID2.Offset(0, WeekNumber).Value = Score2
End If
Next i
End Sub
I am developing a macro to eliminate blank rows from a worksheet which is used for entering customized orders. Lets say rows 7,8,9 and 12 have contents. I want to move the contents of row 12 to row 10.
So far I've located the last occupied row in column c then identified whether the cell in the row in column e is blank or not.
Now I want to put a value into an array either 0 (blank) or 1 (occupied). I am getting an error (object required) on the line of code that sets the value of stones (1) to 1 or 0.
What is going wrong?
Dim ws As Worksheet
Dim rng1 As Range
Set ws = Sheets("Belmont")
Set rng1 = ws.Columns("c").Find("*", ws.[c1], xlValues, , xlByRows, xlPrevious)
Dim zen As String
zen = rng1.Address(0, 0)
Range(zen).Select
Set ruby = Window.ActiveCell.Row - 11
Dim stones() As Boolean
ReDim stones(1 To ruby)
If IsEmpty(ActiveCell.Offset(2, 0)) Then
Set stones(1) = 0
Else
Set stones(1) = 1
End If
msg55 = MsgBox(stones(1), vbDefaultButton1, "Gekko")
My assumption is that you are doing this for purposes of learning rather than practicality:
You could google VBA arrays and get a plethora of material on the subject. I would start here:
http://www.cpearson.com/excel/vbaarrays.htm
You would declare your array like so:
Dim stones(1 To 10) As Double
You're going to have to iterate through each cell in your range. You can Google how to do that as well:
Loop through each cell in a range of cells when given a Range object
You can set the value of the 5th element in the array to the value of 10 like so:
stones(5) = 10
It really seems like you need to do some basic VBA programming tutorials. You could start here:
http://www.mrexcel.com/forum/excel-questions/667818-tutorials-excel-macros-visual-basic-applications.html
If you're trying to get rid of blank cells in sheet 'Belmont' column C, then this should work for you:
Sub tgr()
Dim rngBlanks As Range
With Sheets("Belmont").Range("C1", Sheets("Belmont").Cells(Rows.Count, "C").End(xlUp))
On Error Resume Next
Set rngBlanks = .SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rngBlanks Is Nothing Then rngBlanks.EntireRow.Delete
End With
Set rngBlanks = Nothing
End Sub
If you want to delete all rows in which column C is blank, then:
Sub dural()
Dim r As Range
Set r = Range("C:C").Cells.SpecialCells(xlCellTypeBlanks).EntireRow
r.Delete
End Sub
will accomplish this without looping.