I have difficulty fixing the following problem I am facing:
Lets say I have this code
i_GroupNumberA = Application.WorksheetFunction.CountIf(Sheets("SheetX").Range("G2:G500"), "Red")
i_GroupNumberB = Application.WorksheetFunction.CountIf(Sheets("SheetX").Range("G2:G500"), "Green")
For i = 2 To LastRow
For j = 2 To LastCol
groupNumber = Sheets("Sheet1").Cells(i, j).Value
i_GroupNumberA = 35 'this number a integer that I have got from a cells.value
i_GroupNumberB = 39
If groupNumber = Sheets("Sheet1").Cells(i, j).Value Then
i_Variable = "i_" + groupNumber + "AlphabeticLetter"
MsgBox i_Variable
End If
Next j
Next i
As a result I get i_Variable as a string in a messagebox as an outcome:
i_groupNumberA
I want to have the following result:
35
What I am asking is how can I make get a new variable of a string functioning as a integer.
I am not sure if I am asking this right?
I did as #engineersmnky said, but no effect. I check sites and made some adjustments together with your code. But Still I can't get the needed number in return. So far I got this:
Dim Group As New Collection
i_GroupNumberA = Application.WorksheetFunction.CountIf(Sheets("SheetX").Range("G2:G500"), "Red") 'lets assume it is an number 35
i_GroupNumberB = Application.WorksheetFunction.CountIf(Sheets("SheetX").Range("G2:G500"), "Green") 'lets assume it is an number 39
Group.Add i_GroupNumberA
Group.Add i_GroupNumberB
For i = 2 To LastRow
For j = 2 To LastCol
groupNumber = Sheets("Sheet1").Cells(i, j).Value
i_Variable = "i_" + groupNumber + "AlphabeticLetter"
Group(i_Variable)
Next j
Next i
Group(i_variable) I cant figure it out? for some reason it is not working.
Since you cannot get a variable value from a string in vba I would suggest creating a Collection Object or a Dictionary if you need something more diverse
dim groups AS New Collection
'Value, Key
groups.Add 35, "i_GroupNumberA"
groups.Add 39, "i_GroupNumberB"
Then in your loop instead of the message box you can use
groups(i_Variable)
This will return 35 for "i_GroupNumberA"
Update Collections use an Item and Key structure for Collection(Key) to return the value you want you must specify the key
You may have to build a collection dynamically with your needed group numbers as I am unsure what these are e.g.
Function buildCollection(val As Variant,alpha AS String) AS Collection
Dim groups As New Collection
For i = 2 To LastRow
For j = 2 To LastCol
groupNumber = Sheets("Sheet1").Cells(i, j).Value
i_Variable = "i_" & CStr(groupNumber) & alpha
groups.Add val, i_Variable
Next j
Next i
set buildCollection = groups
End
But without more info about your structure I can't really help beyond basic examples. What is group number? Is it an actual integer? What is A vs B? Please advise as this may be simpler than I originally thought. If you put some sample data or something I am sure I could get this working for you seems like a fairly simple loop. Although you are looping through all the cells and stating that they are all group numbers which seems confusing to me.
Related
Good afternoon,
I am working on an innovative project and cannot seem to figure out the logic of what I need to do. Essentially, I am trying to assign a number of employees to tasks (right now just filling in numbers instead of their names and the actual tasks). Here is a basic look at what the spreadsheet looks like
Task | Task Location | Task Materials | Difficulty | Assignee | Employee List
There are currently 45 tasks, and 30 employees. What I need to do is:
Randomly assort the list of employees to randomize who is doing what
Check to see IF the employee has already been scheduled for 2 tasks, as everybody should have AT LEAST one with nobody having less than two
Loop through the "Employee List" column, IF the Task is blank AND the Employee hasn't been scheduled for more than 2 tasks already, copy that current value from Employee List into Assignee column.
I know this is vague, but I really would appreciate the help. I think the steps are three fold:
Randomize Employee List column
Assign each employee once
Re-randomize employee list
Check to see which tasks still need assigning, and then check to see if the employee has already been scheduled for 2, and, if not, assign them
If they have, skip over and move to the next one
Could anybody help me devise a solution? Here is my current code, which sorts the column, and works well:
Sub ShufflePA()
Application.ScreenUpdating = False
Dim tempString As String, tempInteger As Integer, i As Integer, j As Integer, lastRow As Integer
With Sheets("Test")
lastRow = .Range("F" & .Rows.count).End(xlUp).Row
End With
For i = 6 To lastRow
Cells(i, 7).Value = WorksheetFunction.RandBetween(0, 1000)
Next i
For i = 6 To lastRow
For j = i + 1 To lastRow
If Cells(j, 7).Value < Cells(i, 7).Value Then
'change the string, which is the pa column...
tempString = Cells(i, 6).Value
Cells(i, 6).Value = Cells(j, 6).Value
Cells(j, 6).Value = tempString
tempInteger = Cells(i, 7).Value
Cells(i, 7).Value = Cells(j, 7).Value
Cells(j, 7).Value = tempInteger
End If
Next j
Next i
Worksheets("Test").Range("N:N").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub
I recognize I'll likely need some more subs, and would be willing to work with anybody who could help me. In advance, thank you very much. I am struggling to develop the logic to accomplish what I need.
Try this method for randomly assigning your employees.
Note: You will need to assign your employee column to an array
Here is the Function that will take an array of your employees, and output a random name:
Function randomEmployee(ByRef employeeList As Variant) As String
'Random # that will determine the employee chosen
Dim Lotto As Long
Lotto = randomNumber(LBound(employeeList), UBound(employeeList))
randomEmployee = employeeList(Lotto)
'Remove the employee from the original array before returning it to the sub
Dim retArr() As Variant, i&, x&, numRem&
numRem = UBound(employeeList) - 1
ReDim retArr(numRem)
For i = 0 To UBound(employeeList)
If i <> Lotto Then
retArr(x) = employeeList(i)
x = x + 1
End If
Next i
Erase employeeList
employeeList = retArr
End Function
Notice how I used ByRef? This was intentional because it will replace the input array you provided with a new array that contains all the names, except the one that the function used to give you your random name.
You will also need this function to choose your random number that is called in the above function:
Function randomNumber(ByVal lngMin&, ByVal lngMax&) As Long
'Courtesy of https://stackoverflow.com/a/22628599/5781745
randomNumber = Int((lngMax - lngMin + 1) * Rnd + lngMin)
End Function
This was the test sub I had used. Obviously, you don't want to keep my empListArr, but I kept it there so you can see how this works.
Sub test()
Dim empListArr()
empListArr = Array("Bob", "Joe", "Erin", "Amber")
Debug.Print "Employee Chosen: " & randomEmployee(empListArr)
Dim i As Long
For i = 0 To UBound(empListArr)
Debug.Print "Remaining Employee: ";
Debug.Print empListArr(i)
Next
End Sub
Again, the Test() sub is not intended to be added to your code. It serves as a general guide on using your array of employees with the randomEmployee function.
So put your tasks in a loop, assigning each task one at a time with the randomEmployee function. This function will remove the employees as they are assigned.
Once your array of employees are exhausted you need to reassign your entire column of employees to your array again, so ensure you include a system that checks if your array is empty or not.
Edit:
I performed a test on the randomNumber function just to see how "random" it actually was, using a range between 0 to 10 on a million lines:
Each result hit roughly 9.1%, so it appears to be pretty reliable.
This is what my cells look like:
This is my code, I'll explain it below.
Sub Macro1()
Dim product as String
Dim group as Long
Dim recordno as Long
dim pol_number as Long
dim plan_name as Long
product = "corp"
group = 1
recordno = 1
pol_number = 1
plan_name = "TTT"
Range("A2").Select
For i = 1 to 5
ActiveCell.Value = Selection.End(xlUp).Value
ActiveCell.Offset(0,1).Select
Next i
End Sub
I want to fill in all of the cells with the variable values. I understand that variables are not case sensitive, and I understand that the code I have will just fill the cell with the text in the upmost cell of the column, but I don't know if there is a function that would take the text of the top cell and convert it to a variable. Is that possible?
Try this to go from variables to cells
Dim values as Variant
'Array 0 to 4
values = Array(product,group,recordno,pol_number,plan_name)
Range("A2").Resize(1,5).Value2 = values
The reverse is
Dim values as Variant
'Array 1 to 5
values = Range("A2").Resize(1,5).Value2
product = values(1,1)
group = values(1,2)
recordno = values(1,3)
pol_number = values(1,4)
plan_name = values(1,5)
If you do something like
someCell.Value = someOtherCell.Value
and someOtherCell.Value is "product" then someCell won't be filled with what you have saved in the variable product but with "product" (I included the quotation marks to emphasize that's it's a string). That's a good thing because otherwise it would mess your code up if you accidentally put in the name of some random variable in your code.
If your requirements are like this:
You have values for PRODUCT etc that you write to write in the row below PRODUCT etc.
The headers are not always in the same order.
You might want to add new variables later on without too much fuss.
Them some kind of keyed list might be what your looking for. That means that rather than referencing the variable by a numerical index, you can reference them using names.
If the order is fixed, you might be better of just using an array where item 1 is the product name, item 2 is the group number etc, like ja72 and Sgdva suggested.
However, if you still want to reference the variables by name, you could use a collection:
Dim coll As New Collection
With coll
.Add "corp", "product"
.Add 1, "group"
.Add 1, "recordno"
'...
End With
Then instead of selecting cells and referencing ActiveCell you should reference the cells directly (using selections and ActiveCell can be avoided most of the times and slows down the macro and can even cause unnecessary errors)
For i = 1 To 5
Cells(2, i).value = coll(Cells(1, i).value)
Next i
An alternative to a collection is a dictionary which offers an easy way to check if a key exists (with a collection you have to catch the error)
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With dict
.Add "product", "corp"
.Add "group", 1
.Add "recordno", 1
'...
End With
Now you can check if the entry exists first so it won't throw an error:
For i = 1 To 5
If dict.Exists(LCase(Cells(1, i).value)) Then 'note that the dictionary keys are case sensitive
Cells(2, i).value = dict(LCase(Cells(1, i).value))
Else
MsgBox "Entry for " & LCase(Cells(1, i).value) & " not found!"
End If
Next i
Note that when you use dict("somekey") and the entry "somekey" doesn't exist, it won't throw an error but add an empty entry.
Why not an array and then loop through the elements as needed?
Dim ArrayTitles() As Variant 'since strings and numbers are mixed
ReDim Preserve ArrayTitles(5)
ArrayTitles(1) = "corp"
ArrayTitles(2) = 1
ArrayTitles(3) = 1
ArrayTitles(4) = 1
ArrayTitles(5) = "TTT"
Range("A2").Select
For i = 1 To 5
MsgBox (ArrayTitles(i))
I'm thinking what you are trying to accomplish can be solved in this way
for j = 1 to 6 'Or whatever your last column happens to be
if UCase(cells(1, j)) = "PRODUCT" then
if ActiveCell.Column = j then
ActiveCell.Value = "corp"
end if
end if
next j
Something like that?
Using excel VBA, I have constructed a dictionary and populated it. I did my tests and it's well done.
After that, in a loop I had to test if a key exists to do some operations:
For i3 = 2 To n 'n is the the number of rows
If dicos.Exists(ActiveSheet.Range("T" & i3)) Then
ActiveSheet.Range("N" & i3) = dicos(ActiveSheet.Range("T" & i3)) + 1
Else
ActiveSheet.Range("N" & i3) = 1
End If
Next
It doesn't work and I have 1 in all the column N. I tried to test with some values from the column T manually and it finds it!
Can anyone explain to me what I have done wrong and why the test is positive when I type the value manually and it is negative when the program has to take it from a cell (column T)?
Thank you very much.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim dicos As Dictionary
Set dicos = new Dictionary
'Populate dicos....
For i = 2 To n 'n is the the number of rows
If dicos.Exists(ws.Cells(i, 20).Value) Then
ws.Cells(i, 14) = dicos.Item(ws.Cells(i, 20).Value) + 1
Else
ws.Cells(i, 14) = 1
End If
Next
I believe the problem was that you didn't use .Value on the additive line, thus it was just putting 1 in there. When I tested your code as-posted I changed the +1 to a +4 and got 4 in cells(i,14) instead of 1.
I have a dated CS degree so I understand the basics of VB but I don't write macros very often and need help solving a particular condition. (...but I understand functions and object oriented programming)
Assume the following:
- Column A contains reference ID's in alphanumeric form, sorted alphabetically.
- Column B contains strings of text, or blanks.
I'm trying to write a macro that automatically removes any extra rows for each unique reference number based on the contents of the "Notes" in column B. The problem is that if column A has multiple instances of a unique ref number, I need to identify which row contains something in column B. There is one catch: it is possible that the reference number has nothing in column B and should be retained.
To explain further, in the following screenshot I would need to:
Keep the yellow highlighted rows
Delete the remaining rows
I tried to show various configurations of how the report might show the data using the brackets on the right and marked in red. Its difficult to explain what I'm trying to do so I figured a picture would show what I need more clearly.
This task is making the report very manual and time consuming.
it's pretty simple
you just go throug the rows and check whether this row needs to be deleted, an earlier row with this id needs to be deleted or nothing should happen.
in my example i mark these rows and delete them in the end.
Sub foo()
Dim rngSelection As Range
Dim startingRow As Integer
Dim endRow As Integer
Dim idColumn As Integer
Dim noteColumn As Integer
Dim idValuableRow As New Dictionary
Dim deleteRows As New Collection
Set rngSelection = Selection
startingRow = rngSelection.Row
endRow = rngSelection.Rows.Count + startingRow - 1
idColumn = rngSelection.Column
noteColumn = idColumn + 1
For i = startingRow To endRow
currentID = Cells(i, idColumn)
If idValuableRow.Exists(currentID) Then
If Trim(idValuableRow(currentID)("note")) <> "" And Trim(Cells(i, noteColumn)) = "" Then
deleteRows.Add i
ElseIf idValuableRow(currentID)("note") = "" And Trim(Cells(i, noteColumn)) <> "" Then
deleteRows.Add idValuableRow(currentID)("row")
idValuableRow(currentID)("row") = i
idValuableRow(currentID)("note") = Cells(i, noteColumn)
End If
Else
Dim arr(2) As Variant
idValuableRow.Add currentID, New Dictionary
idValuableRow(currentID).Add "row", i
idValuableRow(currentID).Add "note", Cells(i, noteColumn)
End If
Next i
deletedRows = 0
For Each element In deleteRows
If element <> "" Then
Rows(element - deletedRows & ":" & element - deletedRows).Select
Selection.Delete Shift:=xlUp
deletedRows = deletedRows + 1
End If
Next element
End Sub
it could look something like this. the only thing you need is to add Microsoft Scripting Runtime in Tools/References
I have the following code
For i = 1 To DepRng.Rows.Count
For j = 1 To DepRng.Columns.Count
DepRng.Cells(i, j) = Application.Sum(KidsRng.Row(i)) //Does not work
Next j
Next i
Although I know is wrong, i have no idea how to get it to store in DepRng.Cells(i, j) the total sum of the whole KidsRng.Row[i] Any help?
The following code works ok.
Perhaps you should compare it with yours:
Sub a()
Dim DepRng As Range
Dim kidsrng As Range
Set DepRng = Range("B1:B2")
Set kidsrng = Range("C1:F2")
For i = 1 To DepRng.Rows.Count
DepRng.Cells(i, 1) = Application.Sum(kidsrng.Rows(i))
Next i
End Sub
Just fill the range C1:F2 with numbers and the totals per row will appear in B1:B2 upon execution of the macro.
Sorted, thanks all for ur help
DepRng.Cells(i, j) = Application.Sum(KidsRng.Rows(i)) //just needed to add the "s" in rows
There may be a better way than this, but this is my solution which depends on the internal Excel formula engine though, it might be sufficient enough for what you're doing... It determines the full address of KidsRng.Row(i), and feeds it into a =SUM() formula string and evaluated by Application.Evaluate.
For i = 1 To DepRng.Rows.Count
For j = 1 To DepRng.Columns.Count
DepRng.Cells(i, j).Value = Application.Evaluate("=SUM(" & KidsRng.Row(i).Address(True, True, xlA1, True) & ")")
Next j
Next i
updated it to work if kidsrng existed in a different sheet/book
updated to use Application.Evaluate