How to use VBA to extract the data after the right arrow? - excel

Hello everyone,
I'm doing a challenging task assigned by my supervisor but I'm not sure how to solve this problem. The task that I want to do is to extract the values after the right arrow in column B (Input) and paste it in column C (Output). If there is only one value in the cell (e.g. B4,B8,B9,...), then the output in column C will just be the value. If the cell in column B is empty, then just leave the output column as blank. So the final output should be exactly the same as column C. May I know is there any way to achieve it using VBA scripting? I know that this can be done without using VBA, but I'm requested to use VBA to solve this problem. Any help will be greatly appreciated!

Try the next function, please:
Function extractValLngArrSep(str As String) As Double
Dim x: x = Split(str, " ")
'For the case of empty cell - it will return 0:
If str = "" Then extractValLngArrSep = 0: Exit Function
If UBound(x) > 0 Then
extractValLngArrSep = x(2)
Else
extractValLngArrSep = x(0)
End If
End Function
It can be tested with the next testing Sub. It can be easily applied to all column, just iterating through its cells. Now, please activate one of such a cell with separated numbers and run the code. Then one cell having a simple number:
Sub testExtractVal()
ActiveCell.Offset(0, 1).Value = extractValLngArrSep(ActiveCell.Value)
End Sub
It should be also adapted to catch the case of a single string instead of a number, but this is something out of the question and not very difficult to be handled (I think...).
To process your example range, please use the next code:
Sub testExtractValBis()
Dim sh As Worksheet, lastRow As Long, C As Range
Set sh = ActiveSheet ' please, use here your necessary sheet
lastRow = sh.Range("B" & sh.Rows.count).End(xlUp).row
For Each C In sh.Range("B3:B" & lastRow)
If C.value <> "" Then
C.Offset(0, 1).Value = extractValLngArrSep(C.Value)
End Iff
Next
End Sub

Extract After Character
Adjust the values in the constants section.
The Code
Option Explicit
Sub extractAfterChar()
Const wsName As String = "Sheet1"
Const srcFirst As String = "B3"
Const dstfirst As String = "C3"
Dim Delimiter As String: Delimiter = ChrW(10141)
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Declare variables
Dim rg As Range ' Source Range
Dim wrCount ' Worksheet Rows Count
' Define Source Range.
With wb.Worksheets(wsName).Range(srcFirst)
wrCount = .Worksheet.Rows.Count
Set rg = .Resize(wrCount - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious) ' Define Last Cell Range.
If rg Is Nothing Then Exit Sub ' Validate Last Cell Range.
Set rg = .Resize(rg.Row - .Row + 1) ' Define Source Range.
End With
' Write Source Range's Rows Count to a variable.
Dim rCount As Long: rCount = rg.Rows.Count
' Write values from Source Range to Data Array.
Dim Data As Variant
If rCount > 1 Then
Data = rg.Value ' multiple rows (cells)
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value ' one row (cell) only
End If
' Declare additional variables.
Dim Key As Variant ' Current Value (in Data Array)
Dim i As Long ' Data Array Row Counter
' Replace values in Data Array with results.
For i = 1 To rCount
Key = Data(i, 1)
If IsError(Key) Then
Data(i, 1) = Empty
Else
If Len(Key) = 0 Then ' empty or blank ("")
Data(i, 1) = Empty
Else
Key = Val(rightString(Key, Delimiter))
If Key = 0 Then
Data(i, 1) = Empty
Else
Data(i, 1) = Key
End If
End If
End If
Next
' Write values from Data Array to Destination Range.
With wb.Worksheets(wsName).Range(dstfirst)
.Resize(wrCount - .Row + 1).ClearContents ' from first to bottom-most
.Resize(rCount).Value = Data
End With
End Sub
Function rightString( _
ByVal SearchString As String, _
Optional ByVal Delimiter As String = ",", _
Optional ByVal doTrim As Boolean = True) _
As String
Dim slen As Long: slen = Len(SearchString)
If slen = 0 Then Exit Function
Dim sPos As Long: sPos = InStr(1, SearchString, Delimiter)
If sPos > 0 Then
rightString = Right(SearchString, slen - sPos)
Else
rightString = SearchString
End If
If doTrim Then
rightString = Trim(rightString)
End If
End Function

Related

Repeat even numbers in an array VBA

I'm trying to make a macro for where a user inputs a number and the even numbers are repeated in an array. I have got the code for repeating the numbers from 0-n (n being the number inputted). However, I don't know how to go about repeating the even numbers twice.
Sub Macro3()
For n = 1 To Worksheets("Sheet1").Cells(1, 2) + 1
Cells(2, 1 + n).Select
ActiveCell.FormulaR1C1 = (n - 1)
Next
End Sub
Below is the output
Current code vs what I really want
Write an Array of Integers
Writes an array of integers between 0 and the specified value in cell B1 to a row range starting from B2. Even numbers are written twice (one worksheet).
Initial Solution
This is a slow solution meant to be educational in understanding object variables (workbook-worksheet-range), ranges (Resize, Offset), loops,...
Option Explicit
Sub WriteArrayOfIntegersRange()
Const ProcTitle As String = "Write Array of Integers Range"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Create a reference to the source cell.
Dim sCell As Range: Set sCell = ws.Range("B1")
' Write the value of the source cell to a variable.
Dim sValue As Variant: sValue = sCell.Value
Dim LastInteger As Long
' Validate the source cell value.
If IsNumeric(sValue) Then ' is a number
LastInteger = Abs(CLng(sValue)) ' positive ('Abs'), whole ('CLng')
Else ' is not a number
MsgBox "The value in cell '" & sCell.Address(0, 0) & "' ('" _
& sValue & "' is not a number.", vbCritical, ProcTitle
Exit Sub
End If
' Create a reference to the first destination cell.
Dim dCell As Range: Set dCell = ws.Range("B2"): dCell.Value = 0
Dim Size As Long: Size = 1
Dim n As Long
' Loop through the numbers and apply alternating row size (1 or 2)
' and column offset (2 or 1) before writing.
For n = 1 To LastInteger
Set dCell = dCell.Offset(, Size) ' define next first cell
Size = 2 - n Mod 2 ' calculate the size (Odd = 1, Even = 2)
dCell.Resize(, Size).Value = n ' write to the resized row range
Next n
' Clear the range to the right of the last cell to remove any previous data.
Dim crrg As Range
With dCell.Offset(, Size) ' define next first cell
' Define the range from the next first to the last worksheet cell
' in the row.
Set crrg = .Resize(, ws.Columns.Count - .Column + 1)
End With
crrg.Clear ' or crrg.ClearContents
MsgBox "Array of numbers written.", vbInformation, ProcTitle
End Sub
Using Arrays
This is a more advanced solution that utilizes the multi-purpose GetArrayOfIntegers function. By modifying the related constants (Function Parameters) in the following procedure, you can easily change the output.
Note that it returns the results in another worksheet (Sheet2).
The last procedure is created for anyone to quickly get a flavor of the GetArrayOfIntegers function. Just add a new workbook, add a new module and copy the codes to it. Modify the function parameters in the last procedure to get different results in the Immediate window (Ctrl+G).
Sub WriteArrayOfIntegers()
' Needs the 'GetArrayOfIntegers' function.
Const ProcTitle As String = "Write Array of Numbers"
' Source
Const sName As String = "Sheet1"
Const sCellAddress As String = "B1"
' Destination
Const dName As String = "Sheet2"
Const dfCellAddress As String = "B2"
' Function Parameters ' experiment with these five parameters
Const EvensCount As Long = 2
Const OddsCount As Long = 1
Const DoReturnRow As Boolean = True
Const IncludeZero As Boolean = True
Const IsZeroOdd As Boolean = True
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the source cell.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sCell As Range: Set sCell = sws.Range(sCellAddress)
' Write the value of the source cell to a variable.
Dim sValue As Variant: sValue = sCell.Value
Dim LastInteger As Long
' Validate the source cell value.
If IsNumeric(sValue) Then ' is a number
LastInteger = Abs(CLng(sValue)) ' positive ('Abs'), whole ('CLng')
Else ' is not a number
MsgBox "The value in cell '" & sCell.Address(0, 0) & "' ('" _
& sValue & "' is not a number.", vbCritical, ProcTitle
Exit Sub
End If
' Return the result (an array) of the 'GetArrayOfIntegers' function.
Dim Data As Variant: Data = GetArrayOfIntegers( _
LastInteger, EvensCount, OddsCount, DoReturnRow, IncludeZero, IsZeroOdd)
' Without the constants it would be:
'Data = GetArrayOfIntegers(LastInteger, 2, 1, True, True, True)
If IsEmpty(Data) Then Exit Sub
Dim drCount As Long: drCount = UBound(Data, 1)
Dim dcCount As Long: dcCount = UBound(Data, 2)
' Create a reference to the first destination cell.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dfCellAddress)
' Clear all cells next to (to the right of) and below
' the first destination cell.
Dim dcrg As Range: Set dcrg = dfCell.Resize( _
dws.Rows.Count - dfCell.Row + 1, dws.Columns.Count - dfCell.Column + 1)
dcrg.Clear ' or dcrg.ClearContents
' Create a reference to the destination range.
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
' Write the values from the array to the destination range.
drg.Value = Data
MsgBox "Array of numbers written.", vbInformation, ProcTitle
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Author: VBasic2008
' Dates: 20211101
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns an array of integers in a 2D one-based array.
' Remarks: The first element is always 0 or 1.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetArrayOfIntegers( _
ByVal LastInteger As Long, _
Optional ByVal EvensCount As Long = 1, _
Optional ByVal OddsCount As Long = 1, _
Optional ByVal DoReturnRow As Boolean = False, _
Optional ByVal IncludeZero As Boolean = False, _
Optional ByVal IsZeroOdd As Boolean = False) _
As Variant
Dim eoArr() As Long: ReDim eoArr(0 To 1)
eoArr(0) = EvensCount: eoArr(1) = OddsCount
Dim zCount As Long
If IncludeZero Then
If IsZeroOdd Then zCount = OddsCount Else zCount = EvensCount
End If
Dim iMod As Long: iMod = LastInteger Mod 2
Dim eCount As Long: eCount = Int(LastInteger / 2)
Dim oCount As Long: oCount = Int(LastInteger / 2) + iMod
Dim dtCount As Long
dtCount = eCount * EvensCount + oCount * OddsCount + zCount
Dim Data As Variant
Dim dt As Long: dt = 1
Dim n As Long
Dim r As Long
If DoReturnRow Then
ReDim Data(1 To 1, 1 To dtCount)
If zCount > 0 Then
For dt = 1 To zCount: Data(1, dt) = 0: Next dt
End If
For n = 1 To LastInteger
For r = 1 To eoArr(n Mod 2)
Data(1, dt) = n
dt = dt + 1
Next r
Next n
Else
ReDim Data(1 To dtCount, 1 To 1)
If zCount > 0 Then
For dt = 1 To zCount: Data(dt, 1) = 0: Next dt
End If
For n = 1 To LastInteger
For r = 1 To eoArr(n Mod 2)
Data(dt, 1) = n
dt = dt + 1
Next r
Next n
End If
GetArrayOfIntegers = Data
End Function
' This is an unrelated example to play with.
' Note that changing the fourth parameter will make no difference since
' the results are written to the Immediate window (Ctrl+G).
Sub GetArrayOfIntegersTEST()
' Needs the 'GetArrayOfIntegers' function.
Dim Data As Variant: Data = GetArrayOfIntegers(4, 3, 2, False, False, False)
Dim r As Long, c As Long
For r = 1 To UBound(Data, 1)
For c = 1 To UBound(Data, 2)
Debug.Print Data(r, c)
Next c
Next r
End Sub
Fast alternative via ArrayList
Working with an ArrayList (disposing btw of methods like .Sort,.Remove, .Insert, .Reverse) may be a convenient way to manipulate array data in a very readable way. It is not part of VBA, but can be accessed easily via late binding (referring to .Net library mscorlib.dll).
Option Explicit ' code module head
Sub DoubleEvenNumbersGreaterOne()
'a) define upper limit
Dim ws As Worksheet
Set ws = Sheet1 ' << change to project's sheet Code(Name)
Dim Limit As Long
Limit = ws.Range("B1")
'b) declare ArrayList
Dim arr As Object ' late bind .Net mscorlib.dll
Set arr = CreateObject("System.Collections.ArrayList")
'c) populate list array
arr.Add 0 ' start adding with zero
Dim i As Long
For i = 1 To Limit ' loop through sequence 1:Limit
arr.Add i ' add current number
If i Mod 2 = 0 Then arr.Add i ' additional even number
Next
'd) get array
Dim a As Variant: a = arr.ToArray ' change ArrayList object to VBA array
'Debug.Print Join(a, "|") ' optional check in VB Editor's immediate window
'e) write 0-based 1-dim array to ws (here: Sheet1) or declare another target worksheet (e.g. ws2)
With ws.Range("B2")
.EntireRow = vbNullString ' empty target row
.Resize(1, UBound(a) + 1) = a ' write values into correct number of cells
End With
End Sub
A formula oriented approach // late edit as of 11/1 2021
a) A first and very elementary way would be to
enter formula =COLUMN(A1)-INT((COLUMN(A1)+2)/3) into cell B2 and to
copy into the right neighbour cells as long as you get the wanted maximum
b) Refining this approach you can code the following udf accepting the wanted maximum as argument (note that I changed the flat Column reference to a vertical Row reference to simplify calculation of the actual maxima):
Function Sequ(ByVal maxNo As Long)
Dim myFormula As String
myFormula = Replace("=ROW(1:$)-INT((ROW(1:$)+2)/3)", "$", maxNo + maxNo \ 2 + 1)
Sequ = Application.Transpose(Evaluate(myFormula))
End Function
A direct formula entry of e.g. =Sequ(10) into B2 benefitting from the newer dynamic features of vers. 2019+/MS 365 would display all (row) elements automatically in a so called spill range without need of further inputs.
Using VBA to display results in VB Editor's immediate window could be coded as follows: Debug.Print Join(Sequ(10), "|") resulting in
0|1|2|2|3|4|4|5|6|6|7|8|8|9|10|10
or to assign the results to a variable that can be used in further code.
Your code is really ok, just add question is number even and one more variable to see where to write. Also just change n loop from 0:
Sub Macro3()
For n = 0 To Worksheets("Sheet1").Cells(1, 2)
a = a + 1
Cells(2, 2 + a).Select
ActiveCell.FormulaR1C1 = n
'check if number is even and check if a > 1 because we don't want to repeat 0
If n Mod 2 = 0 And a > 1 Then
a = a + 1
Cells(2, 2 + a).Select
ActiveCell.FormulaR1C1 = n
End If
Next
End Sub
Try this code
Sub Test()
Dim v, ws As Worksheet, i As Long, ii As Long, n As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
v = ws.Range("B1").Value
If Not IsNumeric(v) Or IsEmpty(v) Then MsgBox "Must Be Number", vbExclamation: Exit Sub
ReDim a(1 To (v / 2) + v)
For i = 1 To v
If i Mod 2 = 0 Then
For ii = 1 To 2
n = n + 1: a(n) = i
Next ii
Else
n = n + 1: a(n) = i
End If
Next i
Range("C2").Resize(, UBound(a)).Value = a
End Sub

Column Table convert Matrix Table in VBA code

Current i using formula(index and Match) to create matrix i wish using VBA coding, this will make more fast compair to formula. Thanks in advance
enter image description here
Sub columntomatrix
Dim mS As Worksheet
Dim eS As Worksheet
Set mS = ThisWorkbook.Sheets("Matrix")
Set eS = ThisWorkbook.Sheets("Price Entry Book")
Dim Matrix() As String
Dim entryPrice() As String
Dim Product As Range
Dim PriceBook As Range
Set Product = Range("Product")
Set PriceBook = Range("PriceBookName")
With mS.Range("B2")
.Formula = "=IFERROR(INDEX(ListPrice,
MATCH(" & .Offset(0,-1).Address(False, True) & "&" &
.Offset(-1, 0).Address(True, False) & ",ProductKey,0)),"" N/A "")"
Product.Copy
'offset(0,-1) = selected cells move to left 1 column'
.Offset(0, -1).PasteSpecial
PriceBook.Copy
.offset(-1,0) = selected cells move to up 1 row'
.Offset(-1, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
With Range(.Offset(0, 0), .Offset(Product.Rows.Count - 2, PriceBook.Rows.Count - 2))
.FillDown
.FillRight
End with
End with
End Sub
Pivot RCV
Copy all four procedures to a standard module, e.g. Module1.
Carefully adjust the values in the Define constants. section of pivotRCV.
Only run the first procedure pivotRCV, the others are being called by it.
The Code
Option Explicit
Sub pivotRCV() ' RCV: Row Labels, Column Labels, and Values
' Define constants.
' Define Source constants.
Const srcName As String = "Price Entry Book"
Const srcFirst As String = "A2"
Const rlCol As Long = 1
Const clCol As Long = 2
Const vCol As Long = 4
Const rlSort As Boolean = False
Const clSort As Boolean = False
' Define Target constants.
Const tgtName As String = "Matrix"
Const tgtFirst As String = "A2"
' Define workbooks.
Dim src As Workbook
Set src = ThisWorkbook
Dim tgt As Workbook
Set tgt = ThisWorkbook
' Define Source Range.
' Define Source Worksheet.
Dim ws As Worksheet
Set ws = src.Worksheets(srcName)
' Define Source Range.
Dim rng As Range
Set rng = defineEndRange(ws.Range(srcFirst))
' Write values from Source Range to arrays.
' Write values from Source Range to 1D Unique Row Labels Array.
Dim rLabels As Variant
rLabels = getUniqueColumn1D(rng.Columns(rlCol).Resize(rng.Rows.Count - 1) _
.Offset(1))
If rlSort Then
sort1D rLabels
End If
' Write values from Source Range to 1D Unique Column Labels Array.
Dim cLabels As Variant
cLabels = getUniqueColumn1D(rng.Columns(clCol).Resize(rng.Rows.Count - 1) _
.Offset(1))
If clSort Then
sort1D cLabels
End If
' Write values from Source Range to 2D Source Array.
Dim Source As Variant
Source = rng.Value
' Prepare to write values from Source Array to Target Array.
' Define Target Array.
Dim Target As Variant
ReDim Target(1 To UBound(rLabels) - LBound(rLabels) + 2, _
1 To UBound(cLabels) - LBound(cLabels) + 2)
' Define counters.
Dim n As Long
Dim i As Long
i = 1
' Write values from Source Arrays to Target Array.
' Write first row/column label.
Target(1, 1) = Source(1, 1)
' Write row labels.
For n = LBound(rLabels) To UBound(rLabels)
i = i + 1
Target(i, 1) = rLabels(n)
Next n
' Write column labels.
Dim j As Long
j = 1
For n = LBound(cLabels) To UBound(cLabels)
j = j + 1
Target(1, j) = cLabels(n)
Next n
' Write values.
For n = 2 To UBound(Source, 1)
i = Application.Match(Source(n, rlCol), rLabels, 0) + 1
j = Application.Match(Source(n, clCol), cLabels, 0) + 1
Target(i, j) = Source(n, vCol)
Next n
' Write values from Target Array to Target Range.
' Define Target Worksheet.
Set ws = tgt.Worksheets(tgtName)
' Define Target First Row Range.
With ws.Range(tgtFirst).Resize(, UBound(Target, 2))
' Clear contents from Target First Row Range to the bottom-most row.
.Resize(ws.Rows.Count - .Row + 1).ClearContents
' Define Target Range.
Set rng = .Resize(UBound(Target, 1))
End With
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user.
MsgBox "Data transferred.", vbInformation, "Success"
End Sub
' Defines the range from a specified first cell to the last cell
' of its Current Region.
Function defineEndRange(FirstCellRange As Range) _
As Range
' Define Current Region ('rng').
Dim rng As Range
Set rng = FirstCellRange.CurrentRegion
' Define End Range.
Set defineEndRange = FirstCellRange _
.Resize(rng.Rows.Count + rng.Row - FirstCellRange.Row, _
rng.Columns.Count + rng.Column - FirstCellRange.Column)
End Function
' Returns the unique values from a column range.
Function getUniqueColumn1D(ColumnRange As Range, _
Optional ByVal Sorted As Boolean = False) _
As Variant
Dim Data As Variant
Data = ColumnRange.Columns(1).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
Dim Key As Variant
Dim i As Long
For i = 1 To UBound(Data, 1)
Key = Data(i, 1)
If Not IsError(Key) And Not IsEmpty(Key) Then
.Item(Key) = Empty
End If
Next i
getUniqueColumn1D = .Keys
End With
End Function
' Sorts a 1D array only if it contains the same data type.
Sub sort1D(ByRef OneD As Variant, _
Optional ByVal Descending As Boolean = False)
With CreateObject("System.Collections.ArrayList")
Dim i As Long
For i = LBound(OneD) To UBound(OneD)
.Add OneD(i)
Next i
.Sort
If Descending Then
.Reverse
End If
OneD = .ToArray
End With
End Sub

Paste Mulitple cell values into a single cell

I'm trying to copy the values of a range of cells(A1:A50) into a single cell (B1). I can do it manually by copying the cells to the clipboard and then pasting the clipboard into the formuala bar of B1 but I can't find a way of doing this in a macro other than getting the cells copied to the clipboard.
Hopefully someone can help me out here.
Sheet1.Range("A1:A50").SpecialCells(xlCellTypeConstants).Select
Selection.Copy
I would like the contents of cell B1 to look something like this:
Value of cell A1
Value of cell A2
Value of cell A3
...and so on
Just
Sub myConcat(rSource As Range, rTarget As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
rTarget.Value = Right(sRes, Len(sRes) - Len(sDelimiter))
End Sub
Call it from your code like as
Sub tst_myConcat()
Call myConcat([A1:A50], [B1])
End Sub
Of course, this procedure can be easily converted to a function:
Function myConcat(rSource As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
myConcat = Right(sRes, Len(sRes) - Len(sDelimiter))
End Function
In this case, just write in the target cell (B1) =myConcat(A1:A50)
Do not forget to include in the cell format Wrap text!
First Column To String
The FirstColumnToString function (UDF) has a fixed delimiter (Delimiter) which can manually be changed. But it can e.g. do the following:
=FirstColumnToString(A1:A2,A4,A6:C8,Sheet2!A1:A3)
where it will discard error values and zero-length strings ("") and choose only values from the first column of each range e.g. in range A6:C8 it will choose the values from A6:A8.
The Code
Option Explicit
Function FirstColumnToString(ParamArray SourceRanges() As Variant) _
As String
Const Delimiter As String = vbLf & vbLf
Dim RangesCount As Long
RangesCount = UBound(SourceRanges) - LBound(SourceRanges) + 1
Dim data As Variant
ReDim data(1 To RangesCount)
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Element As Variant
Dim RowsCount As Long
Dim j As Long
For Each Element In SourceRanges
j = j + 1
If Element.Rows.Count > 1 Then
data(j) = Element.Columns(1).Value
Else
data(j) = Help
data(j)(1, 1) = Element.Columns(1).Value
End If
RowsCount = RowsCount + UBound(data(j))
Next Element
Dim Result As Variant
ReDim Result(1 To RowsCount)
Dim Current As Variant
Dim i As Long
Dim k As Long
For j = 1 To RangesCount
For i = 1 To UBound(data(j))
Current = data(j)(i, 1)
If Not IsError(Current) Then
If Current <> vbNullString Then
k = k + 1
Result(k) = Current
End If
End If
Next i
Next j
ReDim Preserve Result(1 To k)
FirstColumnToString = Join(Result, Delimiter)
End Function
A much simpler way of doing the job is to use the TREXTJOIN function in Excel:
With Sheet2.Range("A1:A50")
.AutoFilter Field:=1, Criteria1:="<>"
Sheet2.Range("B1").Value2 = WorksheetFunction.TextJoin(vbCrLf, True, _
.SpecialCells(xlCellTypeVisible))
.AutoFilter
End With

Duplicating cells with address in excel

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

Populate unique values into a VBA array from Excel

Can anyone give me VBA code that will take a range (row or column) from an Excel sheet and populate a list/array with the unique values,
i.e.:
table
table
chair
table
stool
stool
stool
chair
when the macro runs would create an array some thing like:
fur[0]=table
fur[1]=chair
fur[2]=stool
Sub GetUniqueAndCount()
Dim d As Object, c As Range, k, tmp As String
Set d = CreateObject("scripting.dictionary")
For Each c In Selection
tmp = Trim(c.Value)
If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
Next c
For Each k In d.keys
Debug.Print k, d(k)
Next k
End Sub
In this situation I always use code like this (just make sure delimeter you've chosen is not a part of search range)
Dim tmp As String
Dim arr() As String
If Not Selection Is Nothing Then
For Each cell In Selection
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
Combining the Dictionary approach from Tim with the variant array from Jean_Francois below.
The array you want is in objDict.keys
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
This is the old-school way of doing it.
It will execute faster than looping through cells (e.g. For Each cell In Selection) and will be reliable no matter what, as long you have a rectangular selection (i.e. not Ctrl-selecting a bunch of random cells).
Sub FindUnique()
Dim varIn As Variant
Dim varUnique As Variant
Dim iInCol As Long
Dim iInRow As Long
Dim iUnique As Long
Dim nUnique As Long
Dim isUnique As Boolean
varIn = Selection
ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))
nUnique = 0
For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
For iInCol = LBound(varIn, 2) To UBound(varIn, 2)
isUnique = True
For iUnique = 1 To nUnique
If varIn(iInRow, iInCol) = varUnique(iUnique) Then
isUnique = False
Exit For
End If
Next iUnique
If isUnique = True Then
nUnique = nUnique + 1
varUnique(nUnique) = varIn(iInRow, iInCol)
End If
Next iInCol
Next iInRow
'// varUnique now contains only the unique values.
'// Trim off the empty elements:
ReDim Preserve varUnique(1 To nUnique)
End Sub
Profiting from the MS Excel 365 function UNIQUE()
In order to enrich the valid solutions above:
Sub ExampleCall()
Dim rng As Range: Set rng = Sheet1.Range("A2:A11") ' << change to your sheet's Code(Name)
Dim a: a = rng
a = getUniques(a)
arrInfo a
End Sub
Function getUniques(a, Optional ZeroBased As Boolean = True)
Dim tmp: tmp = Application.Transpose(WorksheetFunction.Unique(a))
If ZeroBased Then ReDim Preserve tmp(0 To UBound(tmp) - 1)
getUniques = tmp
End Function
OK I did it finally:
Sub CountUniqueRecords()
Dim Array() as variant, UniqueArray() as variant, UniqueNo as Integer,
Dim i as integer, j as integer, k as integer
Redim UnquiArray(1)
k= Upbound(array)
For i = 1 To k
For j = 1 To UniqueNo + 1
If Array(i) = UniqueArray(j) Then GoTo Nx
Next j
UniqueNo = UniqueNo + 1
ReDim Preserve UniqueArray(UniqueNo + 1)
UniqueArray(UniqueNo) = Array(i)
Nx:
Next i
MsgBox UniqueNo
End Sub
one more way ...
Sub get_unique()
Dim unique_string As String
lr = Sheets("data").Cells(Sheets("data").Rows.Count, 1).End(xlUp).Row
Set range1 = Sheets("data").Range("A2:A" & lr)
For Each cel In range1
If Not InStr(output, cel.Value) > 0 Then
unique_string = unique_string & cel.Value & ","
End If
Next
End Sub
This VBA function returns an array of distinct values when passed either a range or a 2D array source
It defaults to processing the first column of the source, but you can optionally choose another column.
I wrote a LinkedIn article about it.
Function DistinctVals(a, Optional col = 1)
Dim i&, v: v = a
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next
DistinctVals = Application.Transpose(.Keys)
End With
End Function
The old school method was my favourite option. Thank you. And it was indeed fast. But I didn't use redim. Here though is my real world example where I accumulate values for each unique "key" found in a column and move it into a array (say for an employee and values are hours worked per day). Then I put each key with its final values into a totals area on the active sheet. I've commented extensively for anyone who wants painful detail on what is happening here. Limited error checking is done by this code.
Sub GetActualTotals()
'
' GetActualTotals Macro
'
' This macro accumulates values for each unique employee from the active
' spreadsheet.
'
' History
' October 2016 - Version 1
'
' Invocation
' I created a button labeled "Get Totals" on the Active Sheet that invokes
' this macro.
'
Dim ResourceName As String
Dim TotalHours As Double
Dim TotalPercent As Double
Dim IsUnique As Boolean
Dim FirstRow, LastRow, LastColumn, LastResource, nUnique As Long
Dim CurResource, CurrentRow, i, j As Integer
Dim Resource(1000, 2) As Variant
Dim Rng, r As Range
'
' INITIALIZATIONS
'
' These are index numbers for the Resource array
'
Const RName = 0
Const TotHours = 1
Const TotPercent = 2
'
' Set the maximum number of resources we'll
' process.
'
Const ResourceLimit = 1000
'
' We are counting on there being no unintended data
' in the spreadsheet.
'
' It won't matter if the cells are empty though. It just
' may take longer to run the macro.
' But if there is data where this macro does not expect it,
' assume unpredictable results.
'
' There are some hardcoded values used.
' This macro just happens to expect the names to be in Column C (or 3).
'
' Get the last row in the spreadsheet:
'
LastRow = Cells.Find(What:="*", _
After:=Range("C1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'
' Furthermore, this macro banks on the first actual name to be in C6.
' so if the last row is row 65, the range we'll work with
' will evaluate to "C6:C65"
'
FirstRow = 6
Rng = "C" & FirstRow & ":C" & LastRow
Set r = Range(Rng)
'
' Initialize the resource array to be empty (even though we don't really
' need to but I'm old school).
'
For CurResource = 0 To ResourceLimit
Resource(CurResource, RName) = ""
Resource(CurResource, TotHours) = 0
Resource(CurResource, TotPercent) = 0
Next CurResource
'
' Start the resource counter at 0. The counter will represent the number of
' unique entries.
'
nUnique = 0
'
' LET'S GO
'
' Loop from the first relative row and the last relative row
' to process all the cells in the spreadsheet we are interested in
'
For i = 1 To LastRow - FirstRow
'
' Loop here for all unique entries. For any
' new unique entry, that array element will be
' initialized in the second if statement.
'
IsUnique = True
For j = 1 To nUnique
'
' If the current row element has a resource name and is already
' in the resource array, then accumulate the totals for that
' Resource Name. We then have to set IsUnique to false and
' exit the for loop to make sure we don't populate
' a new array element in the next if statement.
'
If r.Cells(i, 1).Value = Resource(j, RName) Then
IsUnique = False
Resource(j, TotHours) = Resource(j, TotHours) + _
r.Cells(i, 4).Value
Resource(j, TotPercent) = Resource(j, TotPercent) + _
r.Cells(i,5).Value
Exit For
End If
Next j
'
' If the resource name is unique then copy the initial
' values we find into the next resource array element.
' I ignore any null cells. (If the cell has a blank you might
' want to add a Trim to the cell). Not much error checking for
' the numerical values either.
'
If ((IsUnique) And (r.Cells(i, 1).Value <> "")) Then
nUnique = nUnique + 1
Resource(nUnique, RName) = r.Cells(i, 1).Value
Resource(nUnique, TotHours) = Resource(nUnique, TotHours) + _
r.Cells(i, 4).Value
Resource(nUnique, TotPercent) = Resource(nUnique, TotPercent) + _
r.Cells(i, 5).Value
End If
Next i
'
' Done processing all rows
'
' (For readability) Set the last resource counter to the last value of
' nUnique.
' Set the current row to the first relative row in the range (r=the range).
'
LastResource = nUnique
CurrentRow = 1
'
' Populate the destination cells with the accumulated values for
' each unique resource name.
'
For CurResource = 1 To LastResource
r.Cells(CurrentRow, 7).Value = Resource(CurResource, RName)
r.Cells(CurrentRow, 8).Value = Resource(CurResource, TotHours)
r.Cells(CurrentRow, 9).Value = Resource(CurResource, TotPercent)
CurrentRow = CurrentRow + 1
Next CurResource
End Sub
The VBA script below looks for all unique values from cell B5 all the way down to the very last cell in column B… $B$1048576. Once it is found, they are stored in the array (objDict).
Private Const SHT_MASTER = “MASTER”
Private Const SHT_INST_INDEX = “InstrumentIndex”
Sub UniqueList()
Dim Xyber
Dim objDict As Object
Dim lngRow As Long
Sheets(SHT_MASTER).Activate
Xyber = Application.Transpose(Sheets(SHT_MASTER).Range([b5], Cells(Rows.count, “B”).End(xlUp)))
Sheets(SHT_INST_INDEX).Activate
Set objDict = CreateObject(“Scripting.Dictionary”)
For lngRow = 1 To UBound(Xyber, 1)
If Len(Xyber(lngRow)) > 0 Then objDict(Xyber(lngRow)) = 1
Next
Sheets(SHT_INST_INDEX).Range(“B1:B” & objDict.count) = Application.Transpose(objDict.keys)
End Sub
I have tested and documented with some screenshots of the this solution. Here is the link where you can find it....
http://xybernetics.com/techtalk/excelvba-getarrayofuniquevaluesfromspecificcolumn/
If you don't mind using the Variant data type, then you can use the in-built worksheet function Unique as shown.
sub unique_results_to_array()
dim rng_data as Range
set rng_data = activesheet.range("A1:A10") 'enter the range of data here
dim my_arr() as Variant
my_arr = WorksheetFunction.Unique(rng_data)
first_val = my_arr(1,1)
second_val = my_arr(2,1)
third_val = my_arr(3,1) 'etc...
end sub
If you are not interested in the count function, then you could simplify the dictionary approach by using empty quotes for the dictionary value instead of the counter. The following code assumes the first cell containing data is "A1". Alternatively, you could use the Selection (though I understand that is generally frowned upon) or the sheet's UsedRange attribute as your range.
Both of the following examples assume that you want to omit blank values from your array of unique values.
Note that to utilize dictionary objects as follows, you must have the Microsoft Scripting Runtime library active in your references. Also note that by declaring dict as a New Dictionary instead of a Dictionary in the beginning, you can forgo the step of setting it equal to a Scripting Dictionary later. Also, dictionary keys must be unique, and this method does not result in errors when setting the value corresponding to a given dictionary key, so there is no risk of having unique keys.
Sub GetUniqueValuesInRange()
Dim cll As Range
Dim rng As Range
Dim dict As New Dictionary
Dim vArray As Variant
Set rng = Range("A1").CurrentRegion.Columns(1)
For Each cll In rng.Cells
If Len(cll.Value) > 0 Then
dict(cll.Value) = ""
End If
Next cll
vArray = dict.Keys
End Sub
The prior example is a slower method, as it is generally preferred to move the values into an array in the beginning, so that all calculations can be performed in the memory. The following should work faster for larger data sets:
Sub GetUniqueValuesInRange2()
Dim vFullArray As Variant
Dim var As Variant
Dim dict As New Dictionary
Dim vUniqueArray As Variant
vFullArray = Range("A1").CurrentRegion.Columns(1).Value
For Each var In vFullArray
If Len(var) > 0 Then
dict(var) = ""
End If
Next var
vUniqueArray = dict.Keys
End Sub

Resources