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
Related
I need to find the earliest & latest dates for certain table entries.
A link to a diagram of the table.
The premise is that every time an entry has a desired pairing of "Name" and "Desc" I want to grab the date, and then find the earliest & latest dates associated with that pairing.
My solution was to create an Array variable, save all the dates in integer form (Long) and then print the Min and Max functions of that Array.
The first date the loop encounters isn't saving to the array, so the first element is always "0" and there's always a date missing.
Sub Test2()
'Search a table for specied subject / entry description, to find the earliest & latest corresponding dates
'Empty array variable for later use
Dim TheDates() As Long
Dim Xds As String
Dim Xnm As String
Dim NameR As Range
Dim Counter As Integer
Dim Dum As Integer
'Placeholder values assigned to Xds and Xnm for testing
Xds = "Charlie # £8.50"
Xnm = "Beatriz"
'Counter set to 0
Counter = 0
ReDim TheDates(Counter)
'Run through each entry in the table
For Each NameR In Range("Draft[Name]")
'Check if an entry contains the desired pairing of Name & Desc ( Xnm & Xds )
If NameR.Value = Xnm And NameR.Offset(0, 8).Value = Xds Then
'In cases they match follow the below procedure
'Set the array size of 'TheDates' to current counter value
'Set the 'counter'th element in the array to the entry's date
'Increment the Counter ready for the next case
ReDim TheDates(Counter)
TheDates(Counter) = CDbl(NameR.Offset(0, 3))
Counter = Counter + 1
'When an entry does not match the desired pairing it is ignored
Else
End If
Next
'For testing purpose I am printing the end results to the page
Range("N13") = WorksheetFunction.Min(TheDates)
Range("N14") = WorksheetFunction.Max(TheDates)
'I am also printing the array in its entirey to analyse
For Dum = 0 To Counter - 1
Range("Q13").Offset(Dum, 0) = TheDates(Dum)
Next
End Sub
I have a short subroutine where I ask the user to specify a starting date using an Inputbox. Currently I copy the starting date to a cell (eg., "A1"), and then use EDate function to advance the date by month for 11 more months to give me a year of dates in Column A, rows 1 through 12.
The code is below:
Sub daterng()
Dim Message, Title, Default, MyValue
Message = "Enter a date in month/day/year format" ' Set prompt.
Title = "Create Date Range"
Default = "10/1/2020"
MyValue = InputBox(Message, Title, Default)
Range("A1") = MyValue
For x = 2 To 12
Cells(x, 1) = "=EDATE(A" & x - 1 & ", 1)" 'Advances date in A1 by a month for 11 months to A2:A12
Next x
End Sub
This works well, and I can then use the range for other purposes. What I would like to do, however, is to assign the values created by the MyValue variable and loop directly to an array. I would like to bypass creating the range altogether - just pass the MyValue value (e.g., "10/1/2020") and resulting 11 months directly into an array. Not sure how to do this. Another issue is that the formula - EDATE - would need to be rewritten to accept the MyValue variable. Suggestions are appreciated. Thanks.
Okay, I asked the question prematurely as I think I figured it out.
Here is the revised code below. It reads a value into the variable MyValue, then loads 12 date values - advanced one month at a time via EDate - into the array "arr". Then I establish a range where I want the array to print out, then set the range equal to the array.
Sub dtearray()
Dim arr(12) As Variant, rng As Range, c As Long
Set rng = Range(Cells(1, 2), Cells(1, 14))
MyValue = "10/1/2020"
For c = 0 To UBound(arr)
arr(c) = WorksheetFunction.EDate(MyValue, c)
Next c
rng = arr
End Sub
I am trying a few items for a Secret Santa spreadsheet.
A Unique ID generator to print the UID in Column B for a list of names in Column A.
A randomizer to print the ID numbers in a random order in Column C with the restraint that Column B UID cannot equal Column C UID, ensuring no one gets themselves.
List Name for the random UID in Column C in Column D.
The UIDs are to start at 1 and then count until the last name receives an ID. I also want the generator to handle creating an ID for a name that is added anywhere in the list (beginning, middle, end).
I found some answers here and on other websites.
Some use complicated looping others the GUID function that I do not understand.
In general, the answers are for existing lists and not a new list with no UIDs.
I assume I would:
Create the UIDs and print them to Column B.
Save Column A and B into an array.
Randomize and Print the UID's into Column C.
Use the array to get the name for the randomized UID's in Column C and print the corresponding name in Column D.
I am unsure if this methodology is a "good" approach for this type of problem, but I would be interested in hearing other methodologies.
The only code I have so far is the row counter.
Sub secret_santa()
Dim person_count As Integer
Dim uid As Integer
'Count Number of Used Rows
person_count = ActiveSheet.UsedRange.Rows.Count
'Subtract Header from person_count
person_count = person_count - 1
End Sub
If I'm reading correctly, you basically just want to shuffle the array whilst also imposing the constraint that no user ID cannot end up corresponding to itself.
There are a number of ways you can implement this. The approach below is not very generalised, can be refactored (to use more functions/subroutines) and a bit clunky. Nonetheless, it might be okay and may give you some ideas regarding implementation:
Option Explicit
Private Function GetArrayOfNames(ByVal someRange As Range) As Variant
' someRange should be a single-column, vertical range.
Debug.Assert someRange.Columns.Count = 1
Debug.Assert someRange.Areas.Count = 1
Debug.Assert someRange.Rows.Count > 1
GetArrayOfNames = someRange.Value
End Function
Private Sub SecretSantaShuffle()
' This procedure will overwrite the contents of the initial range,
' and the three columns to its right.
Dim rangeContainingNames As Range
Set rangeContainingNames = ThisWorkbook.Worksheets("Sheet1").Range("A2:A7")
Dim inputArray() As Variant
inputArray = GetArrayOfNames(rangeContainingNames)
Dim rowCount As Long
rowCount = UBound(inputArray, 1)
ReDim Preserve inputArray(1 To rowCount, 1 To 4)
Const NAME_COLUMN_INDEX As Long = 1
Const UID_COLUMN_INDEX As Long = 2
Const RANDOM_NAME_COLUMN_INDEX As Long = 3
Const RANDOM_UID_COLUMN_INDEX As Long = 4
Do
Dim userIdPool As Collection
Set userIdPool = New Collection
Dim rowIndex As Long
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
inputArray(rowIndex, UID_COLUMN_INDEX) = rowIndex
userIdPool.Add rowIndex, Key:=CStr(rowIndex)
Next rowIndex
For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
Dim randomRowIndex As Long
Do While True
randomRowIndex = userIdPool.Item(Application.RandBetween(1, userIdPool.Count))
If randomRowIndex <> rowIndex Then Exit Do
If userIdPool.Count = 1 Then Exit Do
DoEvents
Loop
userIdPool.Remove CStr(randomRowIndex)
inputArray(rowIndex, RANDOM_NAME_COLUMN_INDEX) = inputArray(randomRowIndex, NAME_COLUMN_INDEX)
inputArray(rowIndex, RANDOM_UID_COLUMN_INDEX) = inputArray(randomRowIndex, UID_COLUMN_INDEX)
Next rowIndex
Loop While userIdPool.Count > 0
rangeContainingNames.Resize(UBound(inputArray, 1), UBound(inputArray, 2)).Value = inputArray
End Sub
You will likely need to change what gets assigned to rangeContainingNames. My list of names was in range A2:A7 of worksheet Sheet1 but you should change the sheet name and range address to reflect the location of your names.
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
I used http://www.homeandlearn.org/arrays_and_loops.html to help me with this.
I have data connections that filter to one table. Unfortunately one of the sources randomly places incorrect data (usually a date) in the wrong column (Client column) when the program exports the file to Excel. What I'd like to do is something similar to an index/match function. I'd like to check each reservation number in this master table (A) against another table (B) within the same workbook. If the reservation number from the other sheet (B) matches the reservation number in the master table (A), I would like to have the correct Client value entered into the master table (A). I'm still pretty new to VBA so any help is appreciated. I've tried to modify my code here and there but to no avail. Also, I was originally running this as a practice without the real data so I didn't mess up my original file. I tried to add the appropriate syntax to refer to other sheets and whatnot so I suppose that could be entered incorrectly as well. Here's the closest original code I came up with:
Sub TransferData()
Dim MyArray(1 To 19) As Single
MyArray(1) = 81899
MyArray(2) = 87172
MyArray(3) = 87275
MyArray(4) = 87394
MyArray(5) = 87446
MyArray(6) = 87496
MyArray(7) = 87621
MyArray(8) = 87631
MyArray(9) = 87726
MyArray(10) = 87822
MyArray(11) = 87858
MyArray(12) = 88041
MyArray(13) = 88097
MyArray(14) = 88127
MyArray(15) = 88160
MyArray(16) = 88191
MyArray(17) = 88359
MyArray(18) = 88487
MyArray(19) = 88545
For i = 1 To 19
If Worksheets("Sheet1").Range("B" & i).Value = MyArray(i) Then
Worksheets("Sheet2").Range("P" & i).Value = _
Worksheets("Sheet1").Range("E" & i).Value
End If
Next i
End Sub
I don't recall the error because the code wasn't exactly as above but close to it. I believe the issue it was running into was that when the i variable went above 19, the system couldn't find arrays > 19. I need VBA to check 19 arrays in an ever changing number of rows that's currently at 3k+. I attempted to add another variable thinking if I kept the variables separate, I could have VBA check the 19 arrays against all the rows. Here's the code I came up with for that....
Sub TransferData()
Dim MyArray(1 To 19) As Single
MyArray(1) = 81899
MyArray(2) = 87172
MyArray(3) = 87275
MyArray(4) = 87394
MyArray(5) = 87446
MyArray(6) = 87496
MyArray(7) = 87621
MyArray(8) = 87631
MyArray(9) = 87726
MyArray(10) = 87822
MyArray(11) = 87858
MyArray(12) = 88041
MyArray(13) = 88097
MyArray(14) = 88127
MyArray(15) = 88160
MyArray(16) = 88191
MyArray(17) = 88359
MyArray(18) = 88487
MyArray(19) = 88545
For i = 1 To 5000
For j = 1 To 19
If Worksheets("Sheet1").Range("B" & i).Value = MyArray(j) Then
Worksheets("Sheet2").Range(i, 16).Value = Worksheets("Sheet1"). _
Range(i,5).Value
Next j
End If
Next i
End Sub
With this code I get compile error: Next without For. In searching online I found it might be because I have 2 "For"s, an if statement, "next" statement within the if statement, then another "next" statement outside of the loop. I was thinking it had to be done this way so that each cell in the B column gets checked against all the array possibilities.
See pictures below. I need the value of Column P (Actual Billing Name) from sheet: TMRtoSPIde to be entered into Column D (Billing Name) on sheet: RawData when the Reservation # in Column K from sheet: TMRtoSPIde matches the reservation in sheet: RawData. You'll notice the sheet: RawData has an erroneous 5 digit serial date in the Billing Name column. These are what I'm trying to replace.
Dictionaries and Collections are ideal for matching unique values. In this example I use a Scripting.Dictionary to store Unique ID's and references to the EntireRow that they are found.
Note: Range().Range() will return a reference that is relative to the first range object (e.g. Range("A10").EntireRow.Range("ZZ1").Address returns $ZZ$10).
It would have simpler to store just the needed value, I just wanted to demonstrate that you can store Objects references in a Dictionary. It is important to note that you can store Objects as both keys and/or values in a Dictionary. A common mistake people make is to try and store range references as keys dictionary.Add Cells(1,1), Cells(1,2) will store a reference to Cells(1,1) as a key and Cells(1,2) as it's value. The problem with this is that Dictionaries don't know how to compare cells and you will not be able to look up your values based on there key relationships. dictionary.Add Cells(1,1).Value, Cells(1,2) is the correct syntax.
Sub TransferData()
Dim r As Range, Source As Range
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
With Worksheets("TMRtoSPIde")
For Each r In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
If Not d.Exists(r.Value) Then d.Add r.Value, r.EntireRow
Next
End With
With Worksheets("RawData")
For Each r In .Range("B2", .Range("B" & .Rows.Count).End(xlUp))
If d.Exists(r.Value) Then
r.EntireRow.Range("K1").Value = d(r.Value).Range("P1").Value
End If
Next
End With
End Sub
Your loop should probably be like this:
For i = 1 To 5000
For j = 1 To 19
If Worksheets("Sheet1").Cells(i, "B").Value = MyArray(j) Then
Worksheets("Sheet2").Cells(i, "P").Value = Worksheets("Sheet1").Cells(i, "E").Value
'Exit from the "For j" loop if we found a match
Exit For
End If
Next j
Next i