Firstly I am storing all the data that I want into an array, then I'll compare it with a column; if it matches then i will take the offset of the value and place it into another column.
But here at the array, I am experiencing "invalid qualifier" error. What am I doing wrong?
Sub database_updator()
Dim dataa As Range, dataCel1 As Range, dataj As Range, datacel2 As Range, datazc As Range, datacel3 As Range, SrchRngaa As Range, cel As Range
Dim data As String, datatext As String, PDS_NAME As String, Database_data As String
Dim n As Integer, xx As Integer, z As Integer
Set dataa = Range("a16:a100")
Set datazc = Range("zc17:zc50")
Set SrchRngaa = Range("a16:a100")
Dim arr(1 To 85) As String
x = 16
For n = 1 To 85 'storing data into array
arr(n) = Range("yx" & x).Value
x = x + 1
Next n
' loop thorugh cells in column
For Each dataCel1 In datazc
For n = 1 To 85
If arr(n) = dataCel1.Value Then
datatext = "true"
Exit For
End If
Next n
' check if current value in column has a match in another column
If datatext = "true" Then
PDS_NAME = arr(n).Value ' ERROR OCCURS HERE
Database_data = dataCel1.Offset(0, 2).Value
For Each cel In SrchRngaa
If PDS_NAME = "" Then
Exit For
ElseIf cel.Value = PDS_NAME Then
cel.Offset(0, 2).Value = Database_data
Exit For
End If
Next cel
End If
Next dataCel1
End Sub
PDS_NAME = arr(n).Value
this should be changed to:
PDS_NAME = arr(n)
Related
I have the following macro that I got from someone, and trying to modify it to suit my purpose.
I'm trying to alter this macro to find and highlight cells that have duplicate values within each cell,
for example, it should highlight B62 and B63 (green),
and color font red the duplicate values (i.e. B_HWY_1010 in B62, and B_HWY_1015 in B63)
Sub Dupes()
Dim d As Object
Dim a As Variant, itm As Variant
Dim i As Long, k As Long
Dim rng As Range
Dim bColoured As Boolean
Set d = CreateObject("Scripting.Dictionary")
Set rng = Range("B1", Range("B" & Rows.Count).End(xlUp))
a = rng.Value
For i = 1 To UBound(a)
For Each itm In Split(a(i, 1), ",")
d(itm) = d(itm) + 1
Next itm
Next i
Application.ScreenUpdating = False
For i = 1 To UBound(a)
k = 1
bColoured = False
For Each itm In Split(a(i, 1), ",")
If d(itm) > 1 Then
If Not bColoured Then
rng.Cells(i).Interior.Color = vbGreen
bColoured = True
End If
rng.Cells(i).Characters(k, Len(itm)).Font.Color = RGB(244, 78, 189)
End If
k = k + Len(itm) + 1
Next itm
Next i
Application.ScreenUpdating = True
End Sub
Any help or advise is appreciated.
The following will do that
Option Explicit
Public Sub Example()
Dim Cell As Range
For Each Cell In Range("A1:A10")
HighlightRepetitions Cell, ", "
Next Cell
End Sub
Private Sub HighlightRepetitions(ByVal Cell As Range, ByVal Delimiter As String)
If Cell.HasFormula Or Cell.HasArray Then Exit Sub ' don't run on formulas
Dim Dict As Object
Set Dict = CreateObject("Scripting.Dictionary")
Dim Data() As String
Data = Split(Cell.Value, Delimiter) ' split data in the cell by Delimiter
Dim StrLen As Long ' length of the string that was already processed
Dim i As Long
For i = LBound(Data) To UBound(Data) ' loop through all data items
Dim DataLen As Long
DataLen = Len(Data(i)) 'get length of current item
If Dict.Exists(Data(i)) Then
' item is a repetition: color it
Cell.Characters(StrLen + 1, DataLen).Font.Color = vbRed
Cell.Interior.Color = vbGreen
Else
' item is no repetition: add it to the dictionary
Dict.Add Data(i), Data(i)
End If
StrLen = StrLen + DataLen + Len(Delimiter) ' calculate the length of the processed string and add length of the delimiter
Next i
End Sub
The following items would be colored:
You can turn ScreenUpdating off before looping in Sub Example() and turn on after the loop to stop it from flickering. Note this will not run on formuas, as parts of formula results cannot be colored. This can be prevented by using If Cell.HasFormula Or Cell.HasArray Then Exit Sub as first line.
Please, try the next code, too:
Sub findComaDelDuplicates()
Dim sh As Worksheet, arr, itm, arrInt, i As Long, rngS As Range, pos As Long
Dim arrDif As Long, j As Long, startPos As Long, arrPos, k As Long, mtch
Set sh = ActiveSheet
With sh.Range("B1", Range("B" & sh.rows.count).End(xlUp))
arr = .value 'put the range value in an array to make the iteration faster
.ClearFormats 'clear previous format
.Font.Color = vbBlack 'make the font color black
End With
For i = 1 To UBound(arr) 'iterate between the array elements:
arrInt = Split(arr(i, 1), ",") 'split the content by comma delimiter
ReDim arrPos(UBound(arrInt)) 'redim the array keeping elements already formatted
For Each itm In arrInt 'iterate between the comma separated elements
arrDif = UBound(arrInt) - 1 - UBound(Filter(arrInt, itm, False)) 'find how many times an element exists
If arrDif > 0 Then 'if more then an occurrence:
If rngS Is Nothing Then 'if range to be colored (at once) does not exist:
Set rngS = sh.Range("B" & i) 'it is crated
Else
Set rngS = Union(rngS, sh.Range("B" & i)) 'a union is made from the previous range and the new one
End If
mtch = Application.match(itm, arrPos, 0) 'check if the itm was already processed:
If IsError(mtch) Then 'if itm was not processed:
For j = 1 To arrDif + 1 'iterate for number of occurrences times
If j = 1 Then startPos = 1 Else: startPos = pos + 1 'first time, inStr starts from 1, then after the first occurrence
pos = InStr(startPos, sh.Range("B" & i).value, itm) 'find first character position for the itm to be colored
sh.Range("B" & i).Characters(pos, Len(itm)).Font.Color = vbRed 'color it
Next j
arrPos(k) = itm 'add the processed itm in the array
End If
End If
Next
Erase arrInt 'clear the array for the next cell value
Next i
If Not rngS Is Nothing Then rngS.Interior.Color = vbGreen 'color the interior cells of the built range
End Sub
Attention: The above code puts the range in an array to iterate much faster. But, if the range does not start form the first row, the cells to be processed must be obtained by adding to i the rows up to the first of the range. The code can be adapted to make this correlation, but I am too lazy to do it now...:)
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
i want to compare the values in the array taken from a certain column with values of another column
but i am getting an error "subscript is out of range"
is there a better way of doing this?
Dim start As Integer
Dim SrchRngzc As Range, cel As Range, SrchRngyx As Range, cel2 As Range
Set SrchRngzc = Range("zc16:zc500")
Set SrchRngyx = Range("yx16:yx100")
Dim x As Integer, a As Integer, b As Integer, c As Integer
Dim y As Integer
Dim n As Integer
Dim arr(1 To 85) As String
Dim num(1 To 85) As Integer
y = 1
c = 1
'highlight cells that matches
For Each cel In SrchRngyx
arr(y) = cel.Value
y = y + 1
Next cel
For Each cel2 In SrchRngzc
n = 1
For c = 1 To y
If arr(n) = cel2.Value Then ' error occurs here
cel2.Interior.ColorIndex = 4
n=n+1
Exit For
End If
Next c
Next cel2
The code below has 1 For to loop through all cells in column "ZC", and then per cell checks if there is a match somewhere in column "YC", by using the Application.Match.
Code
Option Explicit
Sub MatchColumns()
Dim SrchRngzc As Range, Cel As Range, SrchRngyx As Range
Set SrchRngzc = Range("ZC16:ZC500")
Set SrchRngyx = Range("YX16:YX100")
' loop thorugh cells in column "ZC"
For Each Cel In SrchRngzc
' check if courrent value in column "ZC" has a match in column "YX"
If Not IsError(Application.Match(Cel.Value, SrchRngyx, 0)) Then
Cel.Interior.ColorIndex = 4
End If
Next Cel
End Sub
You have set y to 86 at the end of your first For . . . Next loop. When you try to access arr(86) you get your error. Instead try
y=0
For Each cel in SrchRngyx
y = y+ 1
arr(y) = cel.value
Next
This still starts at 1 but ends at 85.
How to vlookup all matches
If i have
ID String
1 xxx
2 yyy
1 zzz
3 ooo
1 ppp
1 zzz
I need vlookup ID=1 anf get in one cell
xxx
zzz
ppp
Application.Vlookup(1;A2:B7;2;False)
Found only first occurents
How to find all unique matches?
You need to create a UDF to do this. Please copy and paste the following code.
(Remember to to early binding for Dictionary Object -- check Microsoft Scripting Runtime in Tool — Reference dialog in VBE.
You can find some detailed explanation and screenshots in http://www.cnblogs.com/hejing195/p/8198584.html )
Function LookUpAllMatches(ByVal lookup_value As String, _
ByVal match_range As Range, _
ByVal return_range As Range, Optional ByVal return_array = False, _
Optional ByVal remove_duplicate = False, _
Optional ByVal delimiter As String = ",")
'By Jing He 2017-12-29
'Last update 2018-02-02
Dim match_index() As Long, result_set() As String
ReDim match_index(1 To match_range.Cells.Count)
Set match_range = zTrim_Range(match_range)
Set return_range = zTrim_Range(return_range)
If match_range.Count <> return_range.Count Then
LookUpAllMatches = "Number of cells in trimed match_range and in trimed return_range are not equal."
Exit Function
End If
Dim i As Long, mc As Long 'used to count, to get the index of a cell in a range
mc = 0 'match count
For i = 1 To match_range.Cells.Count
If match_range.Cells(i).Value = lookup_value Then
mc = mc + 1
match_index(mc) = i
End If
Next i
If mc = 0 Then Exit Function
'Removing duplicate process. Use Scripting.Dictionary object.
If remove_duplicate Then
Dim d As Dictionary, key As String
Set d = New Dictionary
For i = 1 To mc
key = return_range.Cells(match_index(i)).Value
If Not d.Exists(key) Then d.Add key, key
Next i
ReDim result_set(1 To d.Count)
'Convert the hashtable to a array of all the values
its = d.Items
'the index of this items array starts at 0 instead of 1 which is the standard for all the other arraries in ths UDF.
For i = 0 To d.Count - 1
result_set(i + 1) = its(i)
Next i
'close the object; release memeory
Set d = Nothing
Else
ReDim result_set(1 To mc)
For i = 1 To mc
result_set(i) = return_range.Cells(match_index(i)).Value
Next i
End If
If return_array Then
LookUpAllMatches = result_set
Exit Function
End If
Dim result As String
'Convert result_set to a single-line text
result = result_set(1)
For i = 2 To UBound(result_set)
result = result & delimiter & result_set(i)
Next i
LookUpAllMatches = result
End Function
Function zTrim_Range(ByVal rng As Range) As Range
'By Jing He 2017-12-29
'Last update 2017-12-29
Dim maxRow As Long, maxUsedRow As Long, maxUsedRowTemp As Long
maxRow = Columns(1).Cells.Count
If rng.Cells.Count \ maxRow <> 0 Then
'One or multiple columns selected
For i = 1 To rng.Columns.Count
If Cells(maxRow, rng.Cells(1, i).Column) = "" Then
maxUsedRowTemp = Cells(maxRow, rng.Cells(1, i).Column).End(xlUp).Row
If maxUsedRowTemp > maxUsedRow Then maxUsedRow = maxUsedRowTemp
End If
Next i
Set zTrim_Range = Intersect(rng, Range(Rows(1), Rows(maxUsedRow)))
Else
Set zTrim_Range = rng
End If
End Function
For the given problem, the VLOOKUP method will not help. So you have to play with ROW and INDEX array formulas.
Using the record macro function:
' Apply the formula to retrieve the matching value
Selection.FormulaArray = _
"=INDEX(R2C1:R7C2,SMALL(IF(R2C1:R7C1=1,ROW(R2C1:R7C1)),ROW(R[-9]))-1,2)"
Selection.AutoFill Destination:=Range("A10:A13"), Type:=xlFillDefault
' Get the unique values by removing the duplicate
ActiveSheet.Range("$A$10:$A$13").RemoveDuplicates Columns:=1, Header:=xlNo
Using the VBA code
findValue = 1
totalRows = Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
j = 1
For i = 2 To totalRows
If Cells(i, 1).Value = findValue Then
' Fill in the D:D range
Cells(j, 4).Value = Cells(i, 2).Value
j = j + 1
End If
Next
ActiveSheet.Range("D:D").RemoveDuplicates Columns:=1, Header:=xlNo
How can I feed variable "CatchPhrase" with value from each cell from col S...?
I need to select all rows that contain value from each cell in col S.
Problem is that col S have 1996 diferent numbers, and col A have 628790 numbers..
Sub SelectManyRows()
Dim CatchPhrase As String
Dim WholeRange As String
Dim AnyCell As Object
Dim RowsToSelect As String
CatchPhrase = "10044"
'first undo any current highlighting
Selection.SpecialCells(xlCellTypeLastCell).Select
WholeRange = "A1:" & ActiveCell.Address
Range(WholeRange).Select
On Error Resume Next ' ignore errors
For Each AnyCell In Selection
If InStr(UCase$(AnyCell.Text), UCase$(CatchPhrase)) Then
If RowsToSelect <> "" Then
RowsToSelect = RowsToSelect & "," ' add group separator
End If
RowsToSelect = RowsToSelect & Trim$(Str$(AnyCell.Row)) & ":" & Trim$(Str$(AnyCell.Row))
End If
Next
On Error GoTo 0 ' clear error 'trap'
Range(RowsToSelect).Select
End Sub
Example of what I need:
Using the same approach as Is it possible to fill an array with row numbers which match a certain criteria without looping?
You can return an array of numbers from column A (I have used A1:A200 in this example) that match a list in S1:S9 as below
Sub GetEm()
Dim x
x = Filter(Application.Transpose(Application.Evaluate("=if(NOT(ISERROR(MATCH(A1:A200,$S$1:S9,0))),a1:a200,""x"")")), "x", False)
End Sub
The second sub does a direct selection of these cells
Sub GetEm2()
Dim x1
x1 = Join(Filter(Application.Transpose(Application.Evaluate("=if(NOT(ISERROR(MATCH(A1:A200,$S$1:S9,0))),""a""&row(a1:a200),""x"")")), "x", False), ",")
Application.Goto Range(x1)
End Sub
Consider:
Sub dural()
Dim rS As Range, wf As WorksheetFunction
Dim N As Long, aryS As Variant, rSelect As Range
Dim i As Long, v As Variant
'
' Make an array from column S
'
N = Cells(Rows.Count, "S").End(xlUp).Row
Set wf = Application.WorksheetFunction
Set rS = Range("S1:S" & N)
aryS = wf.Transpose(rS)
'
' Loop down column A looking for matches
'
Set rSelect = Nothing
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
v = Cells(i, 1).Value
If v = Filter(aryS, v)(0) Then
If rSelect Is Nothing Then
Set rSelect = Cells(i, 1)
Else
Set rSelect = Union(Cells(i, 1), rSelect)
End If
End If
Next i
'
' Select matching parts of column A
'
rSelect.Select
End Sub