I have been using the below code to run a vlookup-style search and return all matches (whilst omitting duplicates and blanks). I want to convert this into a VBA macro that I can call using a button to, by row, search for the value in column C in column A, and return each corresponding value from column B. I want these results printed in column D, separated by a ";". Does anyone know a good way to do this? I've also attached an example image of my goal output.
Thanks!
Public Function Vlookup2(ByVal Lookup_Value As String, ByVal Cell_Range As
Range, ByVal Column_Index As Integer) As Variant
Dim cell As Range
Dim Result_String As String
On Error GoTo eHandle
For Each cell In Cell_Range
If cell.Value = Lookup_Value Then
If cell.Offset(0, Column_Index - 1).Value <> "" Then
If Not Result_String Like "*" & cell.Offset(0, Column_Index - 1).Value & "*" Then
Result_String = Result_String & ";!;" & cell.Offset(0, Column_Index - 1).Value
End If
End If
End If
Next cell
Vlookup2 = LTrim(Right(Result_String, Len(Result_String) - 1))
Exit Function
eHandle:
Vlookup2 = ""
End Function
Here's one approach you could try:
Sub SummarizeAddresses()
Dim dict As Object, c As Range, ws As Worksheet
Dim pc As String, addr As String, k
Set dict = CreateObject("scripting.dictionary")
Set ws = ActiveSheet 'or whatever
'loop over the input data
For Each c In ws.Range("A2:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).Cells
pc = Trim(c.Value)
addr = c.Offset(0, 1).Value
If Not dict.exists(pc) Then Set dict(pc) = New Collection 'new code?
On Error Resume Next 'ignore error if adding a duplicate
dict(pc).Add addr, addr
On Error GoTo 0 'stop ignoring errors
Next c
Set c = ws.Range("C2") 'starting point for output
For Each k In dict
c.Value = k
c.Offset(0, 1).Value = CollectionItems(dict(k))
Set c = c.Offset(1, 0) 'next row down
Next k
End Sub
'return a string with all elements of a collection
Function CollectionItems(col As Collection)
Dim rv As String, e, sep As String
For Each e In col
rv = rv & sep & e
sep = ";"
Next e
CollectionItems = rv
End Function
Related
Option Explicit
Public Function Vlookup2(ByVal Lookup_Value As String, ByVal Cell_Range As Range, ByVal Column_Index As Integer) As Variant
Dim cell As Range
Dim Result_String As String
On Error GoTo errHandle
For Each cell In Cell_Range
If cell.Value = Lookup_Value Then
If cell.Offset(0, Column_Index - 1).Value <> "" Then
If Not Result_String Like "*" & cell.Offset(0, Column_Index - 1).Value & "*" Then
Result_String = Result_String & ", " & cell.Offset(0, Column_Index - 1).Value
Exit Function
End If
End If
End If
Next cell
Vlookup2 = LTrim(Right(Result_String, Len(Result_String) - 1))
Exit Function
errHandle:
Vlookup2 = ""
End Function
I have the Function Vlookup and it goes through every cell from the top to the bottom, but I want it to go from bottom to top because that'll be faster. I'd be faster because the code will stop at a certain value and odds are that it'll find the value much faster if it starts from below rather than above
I'm answering this so that others, who have this question and come to this post, will have an example even if this isn't suitable or optimal for #Apples.
Sub Example()
'Loops through a range in reverse
'Significantly slower than UsingArrays (see below)
Dim ExampleRange As Range
Set ExampleRange = Sheet1.Range("A1:CA9999")
Dim i As Long, Cell As Range
For i = ExampleRange.Cells.Count To 1 Step -1
Set Cell = ExampleRange.Cells(i)
'Cell now refers to each individual cell within the range in reverse order!
Next i
End Sub
Sub UsingArrays()
'Copies Range to an Array
'Loops through the Array in reverse
Dim ExampleRange As Range
Set ExampleRange = Sheet1.Range("A1:CA9999")
Dim Values As Variant
Values = ExampleRange.Value
If IsArray(Values) Then
Dim i As Long, j As Long, Value As Variant
For i = UBound(Values) To LBound(Values)
For j = UBound(Values, 2) To LBound(Values, 2)
Value = Values(i, j)
'Value now refers to each individual cell's value in reverse order through the array
Next j
Next i
Else
MsgBox "This handles cases where ExampleRange is a single cell."
End If
End Sub
The excel cell has a formula of form =SUM(I1:I5). How can we convert it into its explicit form:
=I1+I2+I3+I4+I5
Another approach with .Precedents:
Sub expandSUM()
Range("A1").Formula = "=SUM(I1:I5)" 'the formula must be in the cell
Output = "=SUM("
For Each cl In Range("A1").Precedents
Output = Output & "+" & cl.Address(False, False)
Next
Debug.Print Replace(Output, "(+", "(") & ")"
End Sub
This feels like a post on Code Golf. Here's my version of a function that can do this.
Function ExplicitSum(ByVal expression As String) As String
Dim strStart As Long, strEnd As Long
strStart = InStr(1, UCase(expression), "SUM(") + 4
If strStart = 0 Then
'SUM not found
ExplicitSum = expression
Exit Function
End If
strEnd = InStr(strStart + 1, expression, ")")
If strEnd = 0 Then
'closing bracket not found
ExplicitSum = expression
Exit Function
End If
Dim LeftText As String, RightText As String, AddressText As String
LeftText = Replace(Left(expression, strStart - 1), "sum(", "(", Compare:=vbTextCompare)
AddressText = Mid(expression, strStart, strEnd - strStart)
RightText = Right(expression, Len(expression) - strEnd + 1)
If InStr(1, UCase(RightText), "SUM(") <> 0 Then
'Recursion will handle multiple sums in the same formula
RightText = ExplicitSum(RightText)
End If
Dim SumRange As Range
On Error Resume Next
Set SumRange = Range(AddressText)
On Error GoTo 0
If SumRange Is Nothing Then
'Invalid AddressText - Named Ranges or Indirect reference
ExplicitSum = LeftText & AddressText & RightText
Exit Function
End If
Dim Addresses() As String
ReDim Addresses(1 To SumRange.Cells.Count)
Dim cell As Range, i As Long: i = 1
For Each cell In SumRange
Addresses(i) = cell.Address(False, False)
i = i + 1
Next cell
ExplicitSum = LeftText & Join(Addresses, "+") & RightText
End Function
Examples of how to use the function:
Sub test()
MsgBox ExplicitSum("=5+sum(A1:D1)/20")
'Displays "=5+(A1+B1+C1+D1)/20"
End Sub
Sub ExampleUsage()
'Put the formula back into the cell after transforming
Range("E1").Formula = ExplicitSum(Range("E1").Formula)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
'Run on every cell with SUM in its formula
If LCase(Target.Cells(1,1).Formula) Like "*sum(*" Then Target.Cells(1,1).Formula = ExplicitSum(Target.Cells(1,1).Formula)
End Sub
Will work with complex formulas.
Will work with multiple SUMS in the same formula.
Will work with Named Ranges inside the Sum.
I wrote a function to do this via string manipulations.
I tested with
Before =SUM(C2:C4,E2:G2,D7:E8)
After =$C$2+$C$3+$C$4+$E$2+$F$2+$G$2+$D$7+$E$7+$D$8+$E$8
Usage, call ExpandSum() with the target cell as an argument
Public Sub ExpandSum(ByVal r_target As Range)
Dim f As String
f = Mid(r_target.Formula, 2)
' Is it a SUM function
If Left(f, 3) = "SUM" Then
' Take the arguments of SUM
f = Mid(f, 5, Len(f) - 5)
' make an array of string with each
' arument
Dim parts() As String
parts = Split(f, ",")
Dim i As Long, n As Long
n = UBound(parts) + 1
Dim rng As Range, cl As Range
Dim col As New Collection
For i = 1 To n
' for each argument find the range of cells
Set rng = Range(parts(i - 1))
For Each cl In rng
' Add each cell in range into a list
col.Add cl.Address
Next
Next i
' Transfer list to array
ReDim parts(0 To col.Count - 1)
For i = 1 To col.Count
parts(i - 1) = col(i)
Next i
' Combine parts into one expression
' ["A1","A2","A3"] => "A1+A2+A3"
f = Join(parts, "+")
r_target.Formula = "=" & f
End If
End Sub
Example of calling with the current selection
Public Sub ThisExpandSum()
Call ExpandSum(Selection)
End Sub
Caveats I don't know how it will behave if the sum contains literal values, or cells from different sheets. That can be functionality to be added later.
Use the next function, please:
Function SUMbyItems(strFormula As String) As String
If strFormula = "" Then Exit Function
Dim rng As Range, Ar As Range, c As Range, strF As String
Set rng = Range(left(Split(strFormula, "(")(1), Len(Split(strFormula, "(")(1)) - 1))
For Each Ar In rng.Areas
For Each c In Ar.cells
strF = strF & c.Address(0, 0) & "+"
Next c
Next
strF = left(strF, Len(strF) - 1)
SUMbyItems = "=SUM(" & strF & ")"
End Function
It can be used, selecting a cell having a SUM formula containing a range and run the next Sub:
Sub testSumByItems()
Debug.Print SUMbyItems(ActiveCell.Formula)
End Sub
If it returns what you want and you need changing the range formula with its expanded version, you can use (in the above testing Sub):
ActiveCell.Formula = SUMbyItems(ActiveCell.Formula)
I am having 10 columns from B to L in excel. I want to check for duplicates within this Range. But I want to know which cell is duplicating with another cell(need a reference of parent one). Please help me to arrive the solution. Here is the code which i tried to solve by getting the "comment with cell address". It is incomplete.
Please suggest best way for this problem.
Thanks in advance.
here is my code
Sub bomstruct()
Dim i As Long
Dim j As Long
Dim f As Long
Dim k As Integer
Dim w As Integer
Range("A3").Select
f = Range(Selection, Selection.End(xlDown)).Rows.Count
Dim Cval As Variant
For k = 3 To f
Cells(k, j).Activate
Cval = Cells(k, j).Value
Cadd = Cells(k, j).Address
If Cval = "" Then
Else
For j = 2 To 12
Cells(i, j).Select
g = f + 3
For i = 790 To g
If i = g Then
Cells(i - g + 3, j + 1).Select
Else
Cells(i, j).Select
If ActiveCell.Value = Cval Then
ActiveCell.Interior.ColorIndex = 6
ActiveCell.AddComment (Cadd)
End If
End If
Next i
i = i - g + 3
Next j
End If
Next k
End Sub
Following code checks for all duplicates and marks (comment and color) the duplicates. It ignores empty cells:
Sub callIt()
Dim rng As Range
' Set the range to check
With ActiveSheet
Set rng = .Range(.Range("A3"), .Range("A3").End(xlDown)).Offset(0, 1).Resize(, 11)
End With
' ===== MAYBE NEEDED ==================================
' Remove color
rng.Interior.colorIndex = 0
' Remove comment if there is one
rng.ClearComments
' ======================================================
' Call the function with the range set
colorizeAndCommentDuplicates rng
End Sub
' Colorize duplicates (same .value) in a range and add comment showing the addresses
' of all duplicates found. Ignores empty cells.
' Args:
' rng (Range): Range to check for duplicates
Sub colorizeAndCommentDuplicates(rng As Range)
Dim rngValuesArray As Variant
Dim i As Long, j As Long
Dim currentValue As Variant
Dim dict As Object, dictDuplicates As Object, rngDuplicates As Range
' Create dict to store ranges
Set dict = CreateObject("Scripting.Dictionary")
Set dictDuplicates = CreateObject("Scripting.Dictionary")
' Write range values into array
rngValuesArray = rng.value
' Loop through range array and find duplicates
For i = LBound(rngValuesArray, 1) To UBound(rngValuesArray, 1)
For j = LBound(rngValuesArray, 2) To UBound(rngValuesArray, 2)
currentValue = rngValuesArray(i, j)
' Skip empty cells
If currentValue <> vbNullString Then
' Only check for duplicates of value if we not already have
If Not dict.exists(currentValue) Then
dict(currentValue) = True
Set rngDuplicates = getDuplicatesRanges(currentValue, rngValuesArray, rng(1))
' Check if duplicates found
If Not rngDuplicates Is Nothing Then
' Add ranges of duplicates to dict
Set dictDuplicates(currentValue) = rngDuplicates
End If
End If
End If
Next
Next
' colorize and add comments
markDuplicates dictDuplicates
End Sub
' Check for duplicates in range values array and return range with duplicates
' if duplicates exist or nothing if there are no duplicates.
' Args:
' valuetoCheck (Variant): Look for duplicates of value.
' rngValuesArray (Variant): Array holding values of a range
' to look for duplicates of value in.
' rngTopLeft (Range): First (top left) range of range to look
' for duplicates in.
' Returns:
' (Range) Nothing if no duplicate found else Range (Areas) of
' duplicates found.
Function getDuplicatesRanges(ByVal valueToCheck As Variant, _
ByVal valuesArray As Variant, ByVal rngTopLeft As Range) As Range
Dim rng As Range, rngTemp As Range
Dim arrayDuplicates() As String
Dim i As Long
Dim j As Long
Dim dictDuplicates
ReDim arrayDuplicates(0)
For i = LBound(valuesArray, 1) To UBound(valuesArray, 1)
For j = LBound(valuesArray, 2) To UBound(valuesArray, 2)
' Value found
If valueToCheck = valuesArray(i, j) Then
If arrayDuplicates(0) <> "" Then
ReDim Preserve arrayDuplicates(UBound(arrayDuplicates) + 1)
End If
arrayDuplicates(UBound(arrayDuplicates)) = i & "," & j
End If
Next
Next
' Loop through array with indexes of duplicates if any found
' and convert to range
If UBound(arrayDuplicates) > 0 Then
For i = 0 To UBound(arrayDuplicates)
Set rngTemp = rngTopLeft.Offset( _
Split(arrayDuplicates(i), ",")(0) - 1, _
Split(arrayDuplicates(i), ",")(1) - 1)
If rng Is Nothing Then
Set rng = rngTemp
Else
Set rng = Application.Union(rng, rngTemp)
End If
Next
Set getDuplicatesRanges = rng
End If
End Function
' Colorize and add comment to duplicates
' Args:
' dict (Object): Scripting dictionary holding values that have
' duplicates as key and all ranges of the duplictaes as values.
Sub markDuplicates(ByRef dict As Object)
Dim key As Variant
Dim rngDict As Range
Dim rng As Range
Dim addresses As String
' Loop through duplicates
For Each key In dict.keys
Set rngDict = dict(key)
' Create string with addresses
For Each rng In rngDict
If addresses <> vbNullString Then addresses = addresses & vbCrLf
addresses = addresses & rng.Address
Next
' Colorize and add comment
For Each rng In rngDict
rng.Interior.colorIndex = 6
rng.ClearComments
rng.AddComment addresses
Next
addresses = vbNullString
Next
End Sub
Highlighting the cells that are duplicate with a conditional formatting rule is one method of 'any other ways to identify'.
with worksheets("sheet1")
with .range("B:L")
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=COUNTIF($B:$L, B1)>1"
End With
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbRed
End With
end with
end with
Here is a macro that will add a comment to each cell listing the addresses of all the duplicates.
Read the notes in the code.
I use a dictionary to detect the duplicates, and each item in the dictionary is a collection of cell addresses where those duplicates can be found.
As written it is "sorted by rows", but you can easily change the looping to sort by columns if you prefer.
The cell with the comment is excluded from the list of duplicates.
Option Explicit
Sub foo()
Dim d1 As Object, col As Collection
Dim v As Variant, w As Variant
Dim i As Long, j As Long
Dim S As String, sComment As String
Dim R As Range, C As Range
Set d1 = CreateObject("Scripting.Dictionary")
d1.CompareMode = TextCompare
'many ways to set bounds of the region to be processed
With Cells(2, 2).CurrentRegion
.ClearComments
v = .Value2 'read values into array for faster processing
End With
'collect the addresses of each value
For i = 1 To UBound(v, 1)
For j = 1 To UBound(v, 2)
If Not d1.exists(v(i, j)) Then
Set col = New Collection
'offset from array index to cell address depends on starting point of array
col.Add Cells(i + 1, j + 1).Address
d1.Add Key:=v(i, j), Item:=col
Else
d1(v(i, j)).Add Cells(i + 1, j + 1).Address
End If
Next j
Next i
'Add the comments
Cells(2, 2).CurrentRegion.ClearComments
For Each v In d1
If d1(v).Count > 1 Then
sComment = ""
S = d1(v)(1)
Set R = Range(S)
For i = 1 To d1(v).Count
S = d1(v)(i)
Set R = Union(R, Range(S))
sComment = sComment & "," & Range(S).Address
Next i
For Each C In R
'Exclude current cell from list of duplicates
S = Mid(Replace(sComment, "," & C.Address, ""), 2)
C.AddComment "Duplicates in" & vbLf & S
Next C
End If
Next v
End Sub
I have two sheets that have two columns with equal values, I want my script when the two values match create a new sheet with the name of value in a second column of the second sheet adjacent to the value found.
The script below stops at the first matching, I wish that the process continues for all possible matches.
Public Sub try()
Dim lastRow As Long
Dim i As Long, j As Long, b As Long, Fente As String, newente As Worksheet
With Worksheets("totale")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To lastRow
With Worksheets("totale")
If .Cells(i, 5).Value = Worksheets("liste").Cells(i, 2).Value Then
Fente = Worksheets("liste").Cells(i, 1).Value
Set newente = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
newente.Name = Fente
i = i + 1
End If
End With
Next i
End Sub
Your code works almost OK there is one issue but not as you describe it the issue that I noticed is that you manually increment i which will result in i=i+2 when match is found and next line will not be checked as it will skip every second line when matched.
I believe the problem is that you might look at wrong records when determining end value of loop or pointing to incorrect columns/sheets for names. Your last row procedure check "Totale" column A but the values you compare are column "B" in "Liste" and column "E" in totale and creates a sheet based on name in "Liste" column "A". If that is incorrect you might need to change your pointers.
So your loop will repeat itself as many times as many records you have in Totale."A" end then stop, additionally you will get an error if Liste.A will be blank or will contain illegal character so I included additional check in the code below.
Public Sub try()
Dim lastRow As Long
Dim i As Long, j As Long, b As Long, Fente As String, newente As Worksheet
With Worksheets("totale")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
For i = 2 To lastRow
With Worksheets("totale")
If .Cells(i, 5).Value = Worksheets("liste").Cells(i, 1).Value Then
Fente = Worksheets("liste").Cells(i, 1).Value
Set newente = ThisWorkbook.Sheets.Add(After:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'check if name is valid and not empty cell
If FileNameValid(Fente) And Fente <> "" Then
newente.Name = Fente
Else
'if not save as illegal name
newente.Name = "bad_name_row_" & i
End If
'i = i + 1 - REMOVE THIS PART. You skip additional line when they are the same
' this is executed and then Next i also increments by one
End If
End With
Next i
End Sub
'check if valid file name is used in cell
Function FileNameValid(sFileName As String) As Boolean
Dim notAllowed As Variant
Dim i As Long
Dim result As Boolean
'list of forbidden characters
notAllowed = Array("/", "\", ":", "*", "?", "< ", ">", "|", """")
'Initial result = OK
result = True
For i = LBound(notAllowed) To UBound(notAllowed)
If InStr(1, sFileName, notAllowed(i)) > 0 Then
'forbidden character used
result = False
Exit Function
End If
Next i
FileNameValid = result
End Function
UPDATE
With the screens you just added it is certain that you point to wrong cells in macro. Swapping those pointers and removing that i+1 should do it.
Cells(i, 5).Value = Worksheets("liste").Cells(i, **1**).Value Then
Fente = Worksheets("liste").Cells(i, **2**).Value
Try the full updated code from above.
I solved the problem.
Here is my code:
Public Sub try()
Dim lastRow As Long, lrow As Long
Dim i As Long, c As Long, Fente As String, newente As Worksheet
With Worksheets("totale")
lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
End With
With Worksheets("liste")
lrow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
For i = 2 To lastRow
For c = 2 To lrow
With Worksheets("totale")
If .Cells(i, 5).Value = Worksheets("liste").Cells(i, 2).Value Then
Fente = Worksheets("liste").Cells(c, 1).Value
'skip to next value if sheet exists
If sheetExists(Fente) = True Then
On Error Resume Next
Else
Set newente = ThisWorkbook.sheets.Add(After:= _
ThisWorkbook.sheets(ThisWorkbook.sheets.Count))
If FileNameValid(Fente) And Fente <> "" Then
newente.Name = Fente
Else
'if not save as illegal name
newente.Name = "bad_name_row_" & i
End If
'NOTE: this will overwrite name set by ELSE
newente.Name = Fente
End If
End If
End With
Next c
Next i
End Sub
'check if valid file name is used in cell
Function FileNameValid(sFileName As String) As Boolean
Dim notAllowed As Variant
Dim i As Long
Dim result As Boolean
'list of forbidden characters
notAllowed = Array("/", "\", ":", "*", "?", "< ", ">", "|", """")
'Initial result = OK
result = True
For i = LBound(notAllowed) To UBound(notAllowed)
If InStr(1, sFileName, notAllowed(i)) > 0 Then
'forbidden character used
result = False
Exit Function
End If
Next i
FileNameValid = result
End Function
Function sheetExists(sheetToFind As String) As Boolean
sheetExists = False
For Each Sheet In Worksheets
If sheetToFind = Sheet.Name Then
sheetExists = True
Exit Function
End If
Next Sheet
End Function
Thank you all.
I'm trying to write a custom function in excel vba that lookup a cell value in a range that returns multiple match values and combine them in one cell.
it returns an error in value #VALUE.
I'm trying to let the user use this function, as writing a sub to do that is working fine.
Function LookUpMoreThanOneResult(LookUpFor As Range, LookUpAt As Range, col As Integer) As Range
Dim Findings As Range
For Each LookUpFor In LookUpFor.Cells
For Each LookUpAt In LookUpAt.Cells
If LookUpFor.Value = LookUpAt.Value Then
Findings.Value = Findings.Value & vbCrLf & LookUpAt.Offset(0, col).Value
End If
Next LookUpAt
Next LookUpFor
LookUpMoreThanOneResult = Findings
End Function
'below is the sub that works fine
Sub look()
Worksheets(1).Activate
Dim ref As Range
Dim arr As Range
Dim va As Range
Set ref = Range("j2:j7595")
Set arr = Worksheets(2).Range("d2:d371")
Dim r As Range
Dim a As Range
For Each r In ref.Cells
For Each a In arr.Cells
If r.Value = a.Value Then
r.Offset(0, 11).Value = r.Offset(0, 11).Value & vbCrLf & a.Offset(0, 6).Value
End If
Next a
Next r
End Sub
this is the answer, here i should not repeat the loop for the LookUpFor cell, and the return value of the function should be String.
so it is owrking fine now, and the user can use it.
Function LookUpMoreThanOneResult(LookUpFor As Range, LookUpAt As Range, col As Integer) As String
Dim R As Range
For Each R In LookUpAt
If LookUpFor.Value = R.Value Then
LookUpMoreThanOneResult = LookUpMoreThanOneResult & vbCrLf & R.Offset(0, col).Value
End If
Next R
End Function