I've tried for a while to find (search) a solution to this but can't seem to.
I'm trying to read a list from an excel document, and based on the "country" item (which is selected on another combobox) filter the list. If it is the right country I want to add the row (4 items) to the combobox row.
I can't use a array because the length changes by country, and since only the second dimension of the array can be dynamic it populates the list backwards.
I currently get this error:
Assignment to constant not permitted.
The code:
Private Sub P_Country_Change()
Dim LastR As Integer
LastR = ActiveWorkbook.Worksheets("M_DB").Range("A2", Worksheets("M_DB").Range("A2").End(xlDown)).Rows.Count
Dim j As Integer
j = 0
For i = 2 To LastR
If ActiveWorkbook.Worksheets("M_DB").Range("E" & i).Value = P_Country.Value Then
With Press_m
.AddItem = ActiveWorkbook.Worksheets("M_DB").Range("A" & i).Value
.List(j, 1) = ActiveWorkbook.Worksheets("M_DB").Range("B" & i).Value
.List(j, 2) = ActiveWorkbook.Worksheets("M_DB").Range("C" & i).Value
.List(j, 3) = ActiveWorkbook.Worksheets("M_DB").Range("D" & i).Value
End With
j = j + 1
End If
Next i
End Sub
Thanks for your help!
Ok, so I made it work. I'm not sure exactly what I did right, but to help anyone else using this as a referenace, one thing I did that may have been it was set the properties of the combobox to:
locked = False
Also I changed the code a little bit, but not so much, here it is now:
Private Sub P_Country_Change()
Dim LastR As Integer
LastR = ActiveWorkbook.Worksheets("M_DB").Range("A2", Worksheets("M_DB").Range("A2").End(xlDown)).Rows.Count
Dim j As Integer
j = 0
For s = P_m.ListCount - 1 To 0 Step -1
P_m.RemoveItem s
Next s
With P_m
.ColumnCount = 4
.ColumnWidths = "125;125;125;125"
.ColumnHeads = False
End With
For i = 2 To LastR
If ActiveWorkbook.Worksheets("M_DB").Range("E" & i).Value = Press_Country.Value Then
P_m.AddItem ActiveWorkbook.Worksheets("M_DB").Range("B" & i).Value ' Name
P_m.List(j, 1) = ActiveWorkbook.Worksheets("M_DB").Range("C" & i).Value ' Corporation
P_m.List(j, 2) = ActiveWorkbook.Worksheets("M_DB").Range("D" & i).Value ' Province
P_m.List(j, 3) = ActiveWorkbook.Worksheets("M_DB").Range("E" & i).Value ' City
j = j + 1
End If
Next i
End Sub
Finally, I found a great referance here. teach me right? RTFM first ;-)
Related
I have the code below to fill all blank cells in a selection with the value from above. I am trying to do the opposite, fill up based on the value below. I think I need to make it loop from the bottom of the selection but don't know how to do that. See below for the result I am going for.
1 1
2
2 2
3
3
3 3
Sub FillDown()
Dim columnValues As Range, i As Long
Set columnValues = Selection
For i = 1 To columnValues.Rows.Count
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i - 1, 1).Value
End If
Next
End Sub
Iterate from the bottom up: For i = columnValues.Rows.Count to 1 Step -1
And change the columnValues.Cells(i - 1, 1).Value to columnValues.Cells(i + 1, 1).Value
Sub FillDown()
Dim columnValues As Range
Set columnValues = Selection
Dim i As Long
For i = columnValues.Rows.Count To 1 Step -1
If columnValues.Cells(i, 1).Value = "" Then
columnValues.Cells(i, 1).Value = columnValues.Cells(i + 1, 1).Value
End If
Next
End Sub
Before:
After:
I would do this slightly differently and populate ranges at a time rather than cells at a time:
Sub FillUp()
Dim CurrRow As Long, FillRow As Long, LastRow As Long
CurrRow = 1
LastRow = Range("A" & Rows.Count).End(xlUp).Row
Do Until CurrRow >= LastRow
If Not IsEmpty(Range("A" & CurrRow + 1)) Then
CurrRow = CurrRow + 1
Else
FillRow = Range("A" & CurrRow).End(xlDown).Row - 1
Range("A" & CurrRow & ":A" & FillRow).Value = Range("A" & CurrRow).Value
CurrRow = FillRow + 1
End If
Loop
End Sub
Using the .end property of a cell reference will allow you to do that which means you are posting less times to the sheet, this will make a big difference in performance if there are large volumes of data or if there are many calculations in the sheet
I know that Scott Craner already knows this but since an answer was posted making reference to optimize performance, I'm pretty sure this is the best approach.
Dim myArray(), i As Long
myArray = columnValues
For i = UBound(myArray) - 1 To LBound(myArray, 1) Step -1
If myArray(i, 1) = "" Then
myArray(i, 1) = myArray(i + 1, 1)
End If
Next i
columnValues = myArray
I have a problem where I want to make Combobox2's result dependent on Combobox1's result.
For example:
a 1 x
a 2 y
b 2 z
b 3 x
c 3 z
d 4 z
Here's the code:
Private Sub Combobox1_Change()
Dim wslk As Worksheet
Set wslk = Worksheets("Sheet1")
Dim i As Integer
Combobox2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.Count).End(xlUp).row
If wslk.Range("B" & i).Value = Combobox1.Value Then
Combobox2.AddItem wslk.Range("A" & i).Value
'The problem starts here
Combobox2.Column(1, i - 2) = wslk.Range("C" & i).Value
Combobox2.ColumnCount = 2
End If
Next i
End Sub
So far it has been able to populate Combobox2 with result from Combobox1.
For instance, if in Combobox1 I choose "a", Combobox2 will show "1" & "2".
However, the moment I choose anything in Combobox1 other than "a" it will crash saying:
Combobox2.Column(1, i - 2) <Could not get the Column property. Invalid property...
Thanks in advance!
Try the next code, please:
Private Sub Combobox1_Change()
Dim wslk As Worksheet, cb2 As MSForms.ComboBox
Set wslk = Worksheets("Sheet1")
Set cb2 = Me.ComboBox2
Dim i As Long
cb2.Clear
For i = 2 To wslk.Range("B" & Application.Rows.count).End(xlUp).Row
If wslk.Range("B" & i).Value = ComboBox1.Value Then
With cb2
.ColumnCount = 2
.AddItem wslk.Range("A" & i).Value
'The problem starts here (not anymore...)
cb2.Column(1, cb2.ListCount - 1) = wslk.Range("C" & i).Value
End With
End If
Next i
End Sub
Your code should add the item after the last existing one (cb2.ListCount - 1)...
I am trying to compare values in two lists. I want my code to compare a value in the first list and check all the entries in the second list. If there is a match then the code will print true next to the value in the first list and if not it will print false.
The problem I am having is that my code only compares values that are in the same row.
The code runs and I have tried it on a two smaller lists to make sure the data types are to same and there aren't any extra spaces or commas in the lists that would lead to a "False" output. I have also tried changing the order of the for and if statements but this doesn't work either.
Sub findvalues()
For i = 2 To 16
For j = 2 To 16
If Cells(i, 3).Value = Cells(i, 1).Value Then
Cells(i, 4).Value = "TRUE"
ElseIf Cells(i, 3).Value = Cells(j + 1, 1).Value Then
Cells(i, 4).Value = "TRUE"
Else
Cells(i, 4).Value = "FALSE"
End If
Next j
Next i
End Sub
Here are the two lists I am testing the code on
Slight mods to your code based on the data you provided in columns 1 & 3. As always, things could be improved but this should get you going ...
Sub findvalues()
Dim i As Long, j As Long, bResult As Boolean
For i = 2 To 16
strValueToLookFor = Cells(i, 1)
For j = 2 To 16
bResult = False
If strValueToLookFor = Cells(j, 3).Value Then
bResult = True
Exit For
End If
Next j
Cells(i, 6).Value = bResult
Next i
End Sub
... you may just need to flick the columns over so the first list searches on the second list or vice versa.
I don't see any need for VBA - formulas are the way to go - but to avoid two loops one could do this:
Sub findvalues()
Dim i As Long
For i = 2 To 130
Cells(i, 4).Value = IsNumeric(Application.Match(Cells(i, 1).Value, Range("C2:C130"), 0))
Next i
End Sub
Update: this does not cater for multiple matches.
There are many was to achieve that. one of them is by using IF & COUNTIF
Formula
=IF(COUNTIF($E$2:$E$6,A2)>0,"TRUE","FALSE")
Results:
VBA CODE
Option Explicit
Sub findvalues()
Dim i As Long
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1") 'Change if needed
Set rng = .Range("A2:A130") 'set rng to includes values from column A, rows 2:130
For i = 2 To 130 'Loop from row 2 to 130
'Check if the values in column C includes in the rng
If Application.WorksheetFunction.CountIf(rng, .Range("C" & i).Value) > 0 Then
.Range("D" & i).Value = "TRUE"
Else
.Range("D" & i).Value = "FALSE"
End If
Next i
End With
End Sub
VBA code to reconcile two lists.
Sub Reconciliation()
Dim endRow As Long
Dim ICount As Long
Dim Match1() As Variant
Dim Match2() As Variant
Dim ws As Worksheet
Set ws = Worksheets("Recon")
ICount = 0
endRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
endRow1 = ws.Cells(ws.Rows.Count, 11).End(xlUp).Row
Match1 = Sheet1.Range("b2:b" & endRow)
Match2 = Sheet1.Range("K2:K" & endRow1)
For i = LBound(Match1) To UBound(Match1)
For j = LBound(Match2) To UBound(Match2)
If Match1(i, 1) = Match2(j, 1) Then
ICount = ICount + 1
Sheet1.Range("C" & i + 1).Value = ICount
Sheet1.Range("L" & j + 1).Value = ICount
Else
End If
Next j
Next i
End Sub
I tried several ways, but I still have a problem in my code.
What I want to do (this example in Q2 on Sheet4):
=INDEX('Sheet8'!K:K,MATCH('Sheet4'!P2,'Sheet8'!A:A,0))
I'd like to do it for all rows with content in column K on Sheet 4 so I'll probably need "For i = 1..."
What I tried:
For i = 1 To LastRowShort
row_mtch = Application.WorksheetFunction.Match(Sheet4.Cells("Q????").Value, Sheet8.Range("A1:A"), 0)
Sheet4.Range("R" & i).Value = Application.WorksheetFunction.Index(Sheet8.Range("K1:K" & LastRowShort), row_mtch)
Next i
Thanks a lot!
Andy
Entire Module:
Sub MissingBoth()
Application.ScreenUpdating = False
Dim MyRange, CopyRange As Range
Dim LastRow As Long
Dim LastRowSheet4 As Long
Dim LastRowSheet8 As Long
Set src4 = Sheet2
Set dst4 = Sheet4
LastRow = src4.Cells(Cells.Rows.Count, "D").End(xlUp).Row
LastRowSheet8 = Worksheets("Sheet8").Cells(Cells.Rows.Count, "B").End(xlUp).Row
LastRowSheet4 = Worksheets("Sheet4").Cells(Cells.Rows.Count, "K").End(xlUp).Row
src4.Unprotect
dst4.Unprotect
If src4.FilterMode = True Then
src4.ShowAllData
End If
dst4.Cells.ClearFormats
dst4.Cells.Clear
'Find content in the "Type of Rack" cells
j = 3
For i = 10 To LastRow
If src4.Cells(i, "CL").Value = "" And src4.Cells(i, "GV").Value = "" Then
src4.Cells(i, "CL").EntireRow.Copy dst4.Cells(j, 1)
j = j + 1
End If
Next i
src4.Range("A6:GW7").Copy Destination:=dst4.Range("A1:GW2")
'Copy every column EXCEPT the following
dst4.Range("GW1,CM1:GU1, U1:CK1,R1:S1,P1,J1:M1").EntireColumn.Delete
For i = 1 To LastRowSheet4
For i2 = 1 To LastRowSheet8
If Worksheets("Sheet4").Range("P" & i).Value = Worksheets("Sheet8").Range("A" & i2).Value Then
Worksheets("Sheet4").Range("Q" & i).Value = Worksheets("Sheet8").Range("K" & i2).Value
End If
Next i2
Next i
dst4.Columns("A:AX").EntireColumn.AutoFit
dst4.Rows("1:500").RowHeight = 15
dst4.Columns("N:O").Interior.Color = vbYellow
dst4.Rows("1:2").Interior.ColorIndex = 15
dst4.Range("B:I").EntireColumn.Hidden = True
Application.ScreenUpdating = True
End Sub
Have you tried something like the following code:
For i = 1 To LastRowSheet4
For i2 = 1 To LastRowSheet8
If Worksheets("Sheet4").Range("P" & i).Value = Worksheets("Sheet8").Range("A" & i2).Value Then
Worksheets("Sheet4").Range("Q" & i).Value = Worksheets("Sheet8").Range("K" & i2).Value
End If
Next i2
Next i
You will just need to define the upper ends of both sheets (LastRowSheet4 and LastRowSheet8) and this should work.
Thanks for your help. I solved the problem with recording a macro and modifying it:
Sheet4.Cells(3, 17).FormulaR1C1 = _
"=INDEX('TS-48 Matrix'!C[-7],MATCH('Missing Both'!RC[-1],'TS-48 Matrix'!C[-16],0))"
Range("Q3").AutoFill Destination:=Range("Q3:Q" & lastRowSheet4)
first time poster, long time reader.
Apologies if this is hard to follow.
I have a spreadsheet which has a list of first names and last names. What I am wanting to do is take all of the first names which have the same last name and place them, evenly(ish) and separated by a comma, into the 3 reference columns in the same spreadsheet for example;
Example of Completed Sheet
I would like to do this in VBA because there are 200+ names and growing, and later the code will use this information to create and populate more workbooks.
So far, what I have works for all last names which have 3 or less first names (ie; one per column) but I cannot get it to work for last names where there are more than 3 first names.
My thought was to read all of the names into an array, split out the elements which have more than 3 names into another array, join these together separated by a comma, to then be transferred to the relevant column on the sheet.
However for some reason, I cannot get it to output more than one name into the column.
I have had a few attempts at this, but this is my latest attempt;
Private Sub cmdUpdate_Click()
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim m As Long
Dim namesPerCol As Long
Dim strLastNameMatches As String
Dim arrNames() As String
Dim arrMultiNames(3) As String
Application.ScreenUpdating = False
With ActiveSheet
'Finds the last row with data in it
lngLastRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
'Sort the Columns
Columns("A:E").Sort key1:=Range("A1"), Header:=xlYes
'Loop through the LastNames
For i = 2 To lngLastRow
'Second loop through the LastNames
For j = 2 To lngLastRow
'If the last name matches
If Cells(i, 2).Value = Cells(j, 2).Value Then
'If the cell is empty then
If Range("C" & i).Value = "" Then
'Place the name in colA into colC
Range("C" & i).Value = Range("A" & j).Value
Else
'If the cell is not empty, then place a comma and space and then the value from colA
Range("C" & i).Value = Range("C" & i).Value & ", " & Range("A" & j).Value
End If
End If
Next j
Next i
For i = 2 To lngLastRow
strLastNameMatches = Range("C" & i).Value
arrNames = Split(strLastNameMatches, ", ")
If UBound(arrNames) > 2 Then
namesPerCol = UBound(arrNames) / 3
For l = 0 To 1
For k = LBound(arrNames) To namesPerCol
arrMultiNames(l) = arrNames(k) & ", "
Next k
Next l
For m = LBound(arrMultiNames) To UBound(arrMultiNames)
Select Case m
Case 0
Range("C" & i).Value = arrMultiNames(m)
Case 1
Range("D" & i).Value = arrMultiNames(m)
Case 2
Range("E" & i).Value = arrMultiNames(m)
End Select
Next m
Else
For j = LBound(arrNames) To UBound(arrNames)
Select Case j
Case 0
Range("C" & i).Value = arrNames(j)
Case 1
Range("D" & i).Value = arrNames(j)
Case 2
Range("I" & i).Value = arrNames(j)
End Select
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
Apologies for the poor quality coding, I will work on tiding it up once it is all working.
Any help I can get to get this code splitting out the names evenly across the three columns will be greatly appreciated
This task might be simpler if you could store your data into a more tree-like structure. There are many ways to do this; I've used the Collection object as it's easy to handle an unknown number of items. Basically, there are collections within a collection, ie one collection of first names for each last name.
The sample below uses very rudimentary distribution code (which is also hard-coded to a split of 3), but the point is that iterating through and down the tree is far simpler:
Dim lastList As Collection, firstList As Collection
Dim lastText As String, firstText As String
Dim data As Variant, last As Variant, first As Variant
Dim output() As Variant, dist(1 To 3) As Long
Dim str As String
Dim r As Long, c As Long, i As Long
'Read data into an array
With Sheet1
data = .Range(.Range("A1"), .Cells(.Rows.Count, "B").End(xlUp)).Value2
End With
'Create lists of unique lastnames containing the firstnames
Set lastList = New Collection
For r = 2 To UBound(data, 1)
firstText = CStr(data(r, 1))
lastText = CStr(data(r, 2))
Set firstList = Nothing
On Error Resume Next
Set firstList = lastList(lastText)
On Error GoTo 0
If firstList Is Nothing Then
Set firstList = New Collection
lastList.Add firstList, lastText
End If
firstList.Add firstText
Next
'Write results to sheet
ReDim output(1 To UBound(data, 1) - 1, 1 To 3)
For r = 2 To UBound(data, 1)
lastText = CStr(data(r, 2))
Set firstList = lastList(lastText)
'Calculate the distribution
dist(3) = firstList.Count / 3 'thanks #Comitern
dist(2) = dist(3)
dist(1) = firstList.Count - dist(2) - dist(3)
i = 1: c = 1: str = ""
For Each first In firstList
str = str & IIf(i > 1, ", ", "") & first
i = i + 1
If i > dist(c) Then
output(r - 1, c) = str
i = 1: c = c + 1: str = ""
End If
Next
Next
Sheet1.Range("C2").Resize(UBound(output, 1), UBound(output, 2)).Value = output