VBA Compare 2 arrays, write unique values to cell with comma delimiter - arrays

I have a series of 2 cells in which values are separated by a comma delimiter.
Example
Cell D1 = 1,2,3,4,5,6,7,8,9,10
Cell O1 = 1,2,3,4,5,6
I want to first use the split function to pass the values to an Array and subsequently compare those 2 Arrays to find out the unique/not double values.
These values then i want to write to another cell as values with a comma delimiter.
Based on this answer
Comparing two Dimension array
and something I found about adding values to an Array i tried my luck with this code
Sub compare()
Dim cont As Long
Dim x As Long
Dim y As Long
Dim Source As Variant
Dim Comparison As Variant
Dim Target As Variant
With ThisWorkbook.Worksheets("Open items")
For cont = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
Source = Split(.Range("D" & cont).Value, ",")
Comparison = Split(.Range("O" & cont).Value, ",")
For x = LBound(Source) To UBound(Source)
For y = LBound(Comparison) To UBound(Comparison)
If Source(x, y) = !Comparison(x, y) Then
Target(UBound(Target)) = Source(x, y).Value
Next
Next
Next cont
End Sub
But seem to be stuck.
Is this the correct way to add a value to the Array Target?
How do I get the Array into the cell?
The result in my example should be for Target to contain "7", "8", "9" , and "10" and should be shown in a cell in the way
7,8,9,10
Thank you for your help!

Some issues:
Rows.Count will look in the active sheet, not necessarily in the "Open items" sheet. So you need to add the dot: .Rows.Count
Source(x, y) will not work, since Source only has one dimension. In fact y has nothing to do with Source. A similar remark holds for Comparison.
= ! is not a valid comparison operator. You maybe intended <>.
Target is not defined, and Target(UBound(Target)) will always refer to the same location. Instead, you could append the result to a string variable immediately.
Furthermore, I would use a Collection object for fast look up, so that the algorithm is not O(n²), but O(n):
Sub Compare()
Dim cont As Long
Dim source As Variant
Dim comparison As Variant
Dim part As Variant
Dim parts As Collection
Dim result As String
With ThisWorkbook.Worksheets("Open items")
For cont = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row
source = Split(.Range("D" & cont).Value, ",")
comparison = Split(.Range("O" & cont).Value, ",")
' Add the source items in a collection for faster look-up
Set parts = New Collection
For Each part In source
parts.Add Trim(part), Trim(part)
Next
' Remove the comparison items from the collection
For Each part In comparison
On Error Resume Next ' Ignore error when part is not in parts
parts.Remove Trim(part)
If Err Then parts.Add Trim(part), Trim(part) ' Add part if not yet in parts
On Error GoTo 0 ' Stop ignoring errors
Next
' Turn the remaining collection to comma-separated string
result = ""
For Each part In parts
result = result & ", " & part
Next
result = Mid(result, 3) ' Remove first comma and space
' Store the result somewhere, for example in the E column
.Range("E" & cont).Value = result
Next cont
End With
End Sub
Alternative for Sorted Lists
When your source and comparison lists are sorted in numerical order, and you need the target to maintain that sort order, you could use a tandem-kind of iteration, like this:
Sub Compare()
Dim cont As Long
Dim source As Variant
Dim comparison As Variant
Dim x As Long
Dim y As Long
Dim result As String
With ThisWorkbook.Worksheets("Open items")
For cont = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row
source = Split(.Range("D" & cont).Value, ",")
comparison = Split(.Range("O" & cont).Value, ",")
x = LBound(source)
y = LBound(comparison)
result = ""
Do While x <= UBound(source) And y <= UBound(comparison)
If Val(source(x)) < Val(comparison(y)) Then
result = result & ", " & Trim(source(x))
x = x + 1
ElseIf Val(source(x)) > Val(comparison(y)) Then
result = result & ", " & Trim(comparison(y))
y = y + 1
Else
x = x + 1
y = y + 1
End If
Loop
' Flush the remainder of either source or comparison
Do While x <= UBound(source)
result = result & ", " & Trim(source(x))
x = x + 1
Loop
Do While y <= UBound(comparison)
result = result & ", " & Trim(comparison(y))
y = y + 1
Loop
result = Mid(result, 3) ' Remove first comma and space
' Store the result somewhere, for example in the E column
.Range("E" & cont).Value = result
Next cont
End With
End Sub

Try this small UDF():
Public Function unikue(BigString As String, LittleString As String) As String
Dim B As Variant, L As Variant, Barr, Larr
Dim Good As Boolean
Barr = Split(BigString, ",")
Larr = Split(LittleString, ",")
For Each B In Barr
Good = True
For Each L In Larr
If L = B Then Good = False
Next
If Good Then unikue = unikue & "," & B
Next B
If unikue <> "" Then unikue = Mid(unikue, 2)
End Function

Couple of things with this code
the variable Target() - You never tell code how big this array is or if you want to make it bigger - my full code below will grow for each match that is found
Source(x, y).Value - You dont need to use Value for arrays. you also do not need x and y as you are only reading in one column you only need source(x)
Where I have wrote MISSING in the full code - these lines where missing and would have caused you issues.
The purpose of Found is that for every time source(x) is found in Comparison(y) then Found is incremented. If it has never been incremented then we can assume that it is to be captured in target.
One other note is that you do not specify where you want to output Target to. so currently the target array does not go anywhere
Sub compare()
Dim cont As Long
Dim x As Long
Dim y As Long
Dim Source As Variant
Dim Comparison As Variant
Dim Target() As Variant
ReDim Target(1)
With ThisWorkbook.Worksheets("Open items")
For cont = 1 To .Cells(.Rows.Count, 4).End(xlUp).Row
Source = Split(.Range("D" & cont).Value, ",")
Comparison = Split(.Range("O" & cont).Value, ",")
For x = LBound(Source) To UBound(Source)
Found = 0
For y = LBound(Comparison) To UBound(Comparison)
If Source(x) = Comparison(y) Then
Found = Found + 1
'count if found
End If 'MISSING
Next
'if values are found dont add to target
If Found = 0 Then
Target(UBound(Target)) = Source(x)
ReDim Preserve Target(UBound(Target) + 1)
End If
Next
Next cont
End With 'MISSING
End Sub

Related

How to join returned values from named range separated by comma

I've spent hours trying to find out how to join returned values from a named range, but the result is a
run-time error 32 - Type mismatch.
As a newbie I'm still struggling with arrays, so maybe I've overlooked some detail. Thank you for helping me out.
Example: (B1)Benzine, (B2)Diesel, (B3)Hybride -> (E1)Gasoline, (E2)Diesel, (E3)Hybrid
This is the named range:
Another example (to be more clear):
Example 2: (B1)Benzine, (B3)Hybride -> (E1)Gasoline, (E3)Hybrid
Option Explicit
Sub splitter()
Dim i As Long
Dim w As Long
'Dim oWB As Workbook
Dim oWS As Worksheet
Dim oWS9 As Worksheet
Dim rngMOTOR As Range
Dim rngMOTOR2 As Range
Dim arrMOTOR() As Variant
Dim LastRow As Long
'Set oWB = Workbooks("BRONBESTAND.xlsm")
Set oWS = Sheets("ONDERDELEN")
Set oWS9 = Sheets("MOTOR") '5 columns: 1 Short & LONG + 1 NL + 3 Languages !!!!! WARNING
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow 'Starting below headers
Set rngMOTOR = oWS.Cells(i, "M") 'MOTOR ...
Set rngMOTOR2 = oWS9.Range("MOTOR") 'MOTOR2: MOTOR - Bronbestand arrPOS = rngPOS2.Value
arrMOTOR = rngMOTOR2.Value
'*********
Dim txt As String
Dim j As Integer
Dim Splitted As Variant
Dim arrMOTORall As Variant
Dim arrMOTORsplit As Variant
Dim Motor3 As String
txt = oWS.Cells(i, "M") 'MOTOR ...
Debug.Print ("txt : ") & i & ": "; txt
If Not IsEmpty(txt) Then
Splitted = Split(txt, ", ")
For j = 0 To UBound(Splitted)
Cells(1, j + 1).Value = Splitted(j)
Debug.Print (" ---> Splitted: ") & Splitted(j)
'**** INSERT *****
For w = LBound(arrMOTOR) To UBound(arrMOTOR)
If arrMOTOR(w, 1) = Splitted(j) Then 'EX: B - Benzine
arrMOTORsplit = (arrMOTOR(w, 4)) '(arrMOTOR(y, 2)) -> 1=SHORT+LONG , 2=NL, 3=FR, 4=EN
Debug.Print (" ---> arrMOTORsplit: ") & i & ": " & arrMOTORsplit
'**** JOIN ****
arrMOTORall = Join(arrMOTORsplit, ", ")
Debug.Print ("arrMOTORall: ") & arrMOTORall
End If
Next w
Next j
End If
Next i
End Sub
Get comma separated strings for each column in named range
I didn't analyze your code, but this should work to receive the first three values joined
"Benzine, Diesel, Hybride" ' e.g. from first column
or
"Gasoline, Diesel, Hybrid" ' e.g. from the fourth column
from a named range "Motor" via the Application.Index function.
Notes
The parameter 0 in this Index function indicates to not choose a specific row, the Parameter ColNo chooses each of your columns in a Loop. A subsequent transposition allows to change the 2 dimensioned array values to a 1-dim array. The Join function needs a 1-dim array and concatenates the chosen column items therein.
Hint: The following sample code uses a fully qualified range reference assuming that you don't call the TestMe procedure from your Personal Macro Library. In the latter case you'd have to change references and workbook identification (not using ThisWorkbook!).
Example code
Option Explicit ' declaration head of your code module
Sub TestMe()
Dim v As Variant, ColNo As Long
' assign first three rows to variant 1-based 2-dim datafield array
v = ThisWorkbook.Worksheets("Motor").[Motor].Resize(3, 4) ' Named range value
' write comma separated list for each column
For ColNo = 1 To 4
Debug.Print Join(Application.Transpose(Application.Index(v, 0, ColNo)), ", ")
Next ColNo
End Sub
EDIT - Flexible Search in ANY ORDER to translate joined lists
This solution allows to return joined search words in any combination using the Application.Index function in an advanced way using row and column arrays as parameters. The main function getSplitters() creates a variant 2-dim array in only three steps without loops and redims and uses two language constants (Const DUTCH and Const ENGLISH).:
assigns data to variant 1-based 2-dim datafield array
gets only the selected rows based on comma separated string values
reduces the same array to Dutch and English columns
Calling Code
Due to your OP the calling code anylyzes all comma separated strings in Column M in your sheet "ONDERDELEN" as far as there are values in column A. This is made by passing these found string values to the main function getSplitters with an innovative approach to get results in only three steps without Loops (see function code below).
Translation is based on values in the named range Motor "B1:E4" in sheet "Motor" where rows comprise different sort of fuel with neighbouring columns for different languages (starting with Dutch in the first column and English in the fourth col).
Note that using VBA it is faster to loop through an array to get values than through a range.
Option Explicit ' declaration head of your code module
Const DUTCH As Integer = 1
Const ENGLISH As Integer = 4
Sub TranslateAnyFuelCombination()
' Purpose: returns comma separated lists in column "M" and translates from Dutch to English
' Example: "Benzine, Hybride, Diesel" (Dutch) gets to "Gasoline, Hybrid, Diesel" in English
Dim s As String
Dim oWS As Worksheet, i&, LastRow&, vMOTOR As Variant
Set oWS = Thisworkbook.Worksheets("ONDERDELEN") ' fully qualified reference
' Get last row of wanted data
LastRow = oWS.Range("A" & Rows.Count).End(xlUp).Row
vMOTOR = oWS.Range("M1:M" & LastRow)
For i = 2 To LastRow 'Starting below headers
Debug.Print getSplitters(vMOTOR(i, 1))
Next i
End Sub
Main function
Function getSplitters(ByVal sRows As String) As String
Dim i As Long, j As Long
Dim v As Variant, a As Variant
' [0] analyze selected rows string, e.g. "Benzine, Hybride, Diesel"
a = getRowAr(sRows) ' -> assign 1-dim Rows Array(1, 3, 2)
' [1] assign data to variant 1-based 2-dim datafield array
v = Application.Transpose(ThisWorkbook.Worksheets("Motor").[Motor]) ' Named range value
' [2] get only selected rows, e.g. 1st, 3rd and 2nd -> in free order (!) Benzine, Hybride, Diesel
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v, 2) & ")"), _
a)) ' transposed columns array = selected rows
' [3] reduce to Dutch and English columns
v = Application.Transpose(Application.Index(v, _
Application.Evaluate("row(1:" & (UBound(a) + 1) & ")"), _
Array(DUTCH, ENGLISH))) ' selected columns array (above array retransposed)
' [4] return concatenated strings
getSplitters = Join(Application.Transpose(Application.Transpose(Application.Index(v, 1, 0))), ", ") & " -> " & _
Join(Application.Transpose(Application.Transpose(Application.Index(v, 2, 0))), ", ")
End Function
Two helper functions
Function getRowAr(ByVal sList As String) As Variant
' Purpose: split comma separated list into 1-dim number array in FREE ORDER
' Example: "Benzine, Hybride, Diesel" -> Array(1, 3, 2)
Dim ar, i&
' change words in comma separated list to numbers
ar = Split(Replace(sList, " ", ""), ",")
For i = LBound(ar) To UBound(ar)
ar(i) = val(getNumber(ar(i))) ' change to numbers
Next i
getRowAr = ar ' return
End Function
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
getNumber = Application.Match(s, arFuel)
End Function
Addendum (Edit due to comment)
The above code works as intended if you are sure that the concatenated search words (or starting parts) actually match else an Error 13 is raised. You can solve this issue in two steps:
Insert an empty first row into your named range Motor (or fill it e.g. with ?, #N/A etc.)
Change the 2nd helper function as follows:
Edited function getNumber()
Function getNumber(ByVal s As String) As Long
' Purpose: replaces dutch search words with corresponding row number
Dim arFuel
' get search words to 1-dim array
arFuel = Application.Index(ThisWorkbook.Worksheets("Motor").[Motor], 0, DUTCH)
' return corresponding number
On Error Resume Next ' provide for not found case
getNumber = Application.Match(s, arFuel, 0) ' find only exact matches
If Err.Number <> 0 Then getNumber = 0 ' could be omitted in case of a zero return
End Function
With 2 arrays this is a possible solution:
Sub TestMe()
Dim inputString As String
Dim arrString As Variant
Dim arrResult As Variant
inputString = "Benzine, Diesel, Hybride"
arrString = Split(inputString, ",")
Dim total As Long: total = UBound(arrString)
ReDim arrResult(total)
Dim i As Long
For i = LBound(arrString) To UBound(arrString)
arrResult(total - i) = Trim(arrString(i))
Next i
Debug.Print Join(arrResult, " ,")
End Sub
However, there is a classic solution of this problem, reversing everything twice:
Sub TestMe()
Dim inputString As String
inputString = "Benzine, Diesel, Hybride"
inputString = StrReverse(inputString)
Dim arr As Variant: arr = Split(inputString, ",")
Dim i As Long
For i = LBound(arr) To UBound(arr)
arr(i) = Trim(StrReverse(arr(i)))
Next i
Debug.Print Join(arr, ", ")
End Sub

Array splitting and extracting

I'm attempting to go through each character in a cell to determine whether or not a word is underlined and italicized but so far the loop runs and freezes. How can I copy and move the word that is italicized and underlined? This is what I have so far. I asked a new question because I wasn't clear enough in this one. It can be accessed at Array split and extract vba excel .
For Each j In ActiveSheet.Range("C1:C105")
v = Trim(j.Value)
If Len(v) > 0 Then
v = Replace(v, vbLf, " ")
Do While InStr(v, " ") > 0
v = Replace(v, " ", " ")
Loop
arr = Split(v, " ")
For Z = LBound(arr) To UBound(arr)
e = arr(Z)
For i = 1 To Len(v)
If j.Characters(i, 1).Font.Italic = True And j.Characters(i, 1).Font.Underline = True Then
j.Value.Copy
End If
Next i
Next Z
End If
Next j​
The following piece of code will Debug.Print all the words that are underlined and formatted italic in any of the given cells:
Option Explicit
Public Sub tmpSO()
Dim i As Long
Dim j As Range
Dim StartPoint As Long
Dim InItalicUnderlinedWord As Boolean
For Each j In ThisWorkbook.Worksheets(1).Range("C1:C105")
If Len(j.Value2) > 0 Then
For i = 1 To Len(j.Value2)
If j.Characters(i, 1).Font.Italic And j.Characters(i, 1).Font.Underline Then
If InItalicUnderlinedWord = False Then
StartPoint = i
InItalicUnderlinedWord = True
End If
Else
If InItalicUnderlinedWord = True Then
Debug.Print Mid(j.Value2, StartPoint, i - StartPoint)
InItalicUnderlinedWord = False
End If
End If
If InItalicUnderlinedWord = True And i = Len(j.Value2) Then
Debug.Print Mid(j.Value2, StartPoint, i - StartPoint + 1)
InItalicUnderlinedWord = False
End If
Next i
End If
Next j
End Sub
Debug.Print will output the italic and underlined word into the immediate window of the VBE. If you want these words anywhere else then you'll have to adjust the code in two (!) places:
Once in the section which starts with InItalicUnderlinedWord for any find anywhere within a cell and
in the section which starts with If InItalicUnderlinedWord = True And i = Len(j.Value2) Then for any occurrences where the last character in a cell is also underlined and italic.
Let me know if you have any questions or problems.
something like this, only does 1 cell, so you'll need to add it to your loop
Sub test()
Dim r As Range
Dim v As Variant
Dim i As Integer
Dim f As Integer
Set r = Range("h2")
v = Split(r.Value, Chr(32))
For i = 0 To UBound(v) - 1
f = InStr(1, r, v(i)) ' equiv Application.WorksheetFunction.Search(v(i), r)
If r.Characters(f, 1).Font.Italic Then
Debug.Print v(i) & " is italic"
End If
Next i
End Sub
A slightly simpler implementation involves copying the entire cell values first, and then manipulating the copied range. Call this in a loop, and provide it the two arguments: rngToCopy = the cell being copied and rngToPaste the destination cell (qualified to specific workbook/worksheet):
For each cl in Range("C1:C105")
Call CopyItalicUnderlined(cl, __Some Place Else__)
Next
Here's the procedure
Sub CopyItalicUnderlined(rngToCopy, rngToPaste)
rngToCopy.Copy rngToPaste
Dim i
For i = Len(rngToCopy.Value2) To 1 Step -1
With rngToPaste.Characters(i, 1)
If Not .Font.Italic And Not .Font.Underline Then
.Text = vbNullString
End If
End With
Next
End Sub

Checking for duplicate substrings in Excel

I am trying to find a way to compare the first significant words in each cell with first significant words in the next cell, and if the first significant words matches, it removes the second entry. For example, the starting data can look like this:
General Electric
General Electric Inc
General Electric Company
Microsoft
Microsoft Corporation
Microsoft Servers
Nintendo
Nintendo Enterprises
And the result should end up looking like this:
General Electric
Microsoft
Nintendo
So far, I have this code set up that traverses the column of data:
Sub CompanyNameConsolidate()
Dim companyName As String
Dim companyArray() As String
Dim companyName2 As String
Dim companyArray2() As String
Dim totalArray() As String
Dim wordCount As Integer
Dim i As Integer
Dim r As Range
With Sheets("Unassigned")
Range("B1").Select
Do Until IsEmpty(ActiveCell)
companyName = Range("B" & ActiveCell.Row).Text
companyName2 = ActiveCell.Offset(1, 0).Text
companyArray = Split(companyName, " ")
companyArray2 = Split(companyName2, " ")
wordCount = UBound(companyArray) - LBound(companyArray)
For i = 0 To wordCount
If companyArray(i) = companyArray2(i) Then
[*********HELP**********]
Next
ActiveCell.Offset(1, 0).Select
Loop
End With
End Sub
Basically, the code above compares the substrings in each cell with the substrings in the next cell. Unfortunately, that's as far as I have gotten.
The tricky thing is that some company names can have two words (General Electric) and others can have only one word (Microsoft).
You can assume that the list will be sorted in alphabetical order, so the shortest name (the name I want to keep) will always be on top.
I have over 16,000 entries to go through and fix, so I absolutely must have an automated way of doing it!
1st variant using rows deletion:
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim x&, cl As Range, DataRange As Range, k1, k2
Dic.comparemode = vbTextCompare
With Sheets("Unassigned")
Set DataRange = .[B1].Resize(.Cells(Rows.Count, "B").End(xlUp).Row, 2)
x = 1
For Each cl In DataRange
If cl.Value <> "" Then
Dic.Add x, cl.Value
x = x + 1
End If
Next cl
For Each k1 In Dic
For Each k2 In Dic
If IsNumeric(k1) And IsNumeric(k2) Then
If Dic(k2) Like Dic(k1) + "*" And k2 > k1 Then
Dic.Remove (k2)
End If
If Not Dic.exists(Dic(k1)) Then Dic.Add Dic(k1), Nothing
End If
Next k2, k1
x = Split(DataRange.Address, "$")(4)
While x <> 0
If Not Dic.exists(.Cells(x, "B").Value) Then .Rows(x).Delete
x = x - 1
Wend
End With
End Sub
2nd variant using Workbook.Add:
Sub test2()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim x&, cl As Range, DataRange As Range, k1, k2
Dic.comparemode = vbTextCompare
With Sheets("Unassigned")
Set DataRange = .[B1].Resize(.Cells(Rows.Count, "B").End(xlUp).Row, 2)
x = 1
For Each cl In DataRange
If cl.Value <> "" Then
Dic.Add x, cl.Value
x = x + 1
End If
Next cl
For Each k1 In Dic
For Each k2 In Dic
If Dic(k2) Like Dic(k1) + "*" And k2 > k1 Then
Dic.Remove (k2)
End If
Next k2, k1
End With
Workbooks.Add
x = 1
For Each k1 In Dic
Cells(x, 2) = Dic(k1)
x = x + 1
Next k1
End Sub
test for both variants
before: ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~> after:
Find a common demoninator for your company names, according to your examples this appears to just remove the last word, if its greater than 1 word.
Dim listOfCompanies As New Collection
Dim companyName As String
Dim companyArray As Variant
Dim item As Variant
Dim i as Integer, j As Integer
'The 2 denotes column B, where i denotes the row
'You can change this outter loop to your specific needs, this one just processes the first column B1, to when it encounters a blank row
while(ThisWorkbook.Worksheets("Unassigned").Cells(i, 2).Value <> "")
companyName = ThisWorkbook.Worksheets("Unassigned").Cells(i, 2).Value
companyArray = Split(companyName, " ")
companyName = ""
'This truncates the last word off
for j = 0 to UBound(companyArray) - 1
companyName = companyName + companyArray(j) + " "
next j
'Trim off the last space character
companyName = Trim(companyName)
'Now Add your companyName string to a Dictionary Object
'VBA will throw an error if a duplicate gets added, but this is okay and we can continue processing
On Error Resume Next
listOfCompanies.Add(companyName)
On Error Goto 0 'This resets the handler in case an error occurs somewhere else unexpectedly
i = i + 1
wend
'Now we can do a ForEach and spit out the entire 'unique list'
For Each item in listOfCompanies
'Your code here
Next item

Go through values in range, search for them in range, find value in respective rows, add them to array

I would like to go through a range of values in Column D and take each value:
for each value
check in the same range for its occurrence
check in the row of its occurrence for a value in column A
Add this value in column a to an array (or another way to save data)
go to the next occurrence of the value in column D and save the next Value of Column A to the array
When I checked each value for all its occurrences and added it to the array I want the array to be given out in the cell H1 (and for the next values onwards, I1 and so on)
Here's a picture of what I mean with some dummy values:
My attempts in VBA so far are this (with the remark that I deal with arrays for the first time):
Dim finden As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim i As Integer
Dim zahl As Integer
Dim zeile As Range
Dim temparray As Double
Dim b As Integer
Dim count As Integer
Set rng = Worksheets("Tabelle1").Range("H1:H100")
i = Worksheets("Tabelle1").Cells(Rows.count, "D").End(xlUp).Row
For zahl = 1 To i
finden = Sheets("Tabelle1").Cells(zahl, "D").Value
count = Application.WorksheetFunction.CountIf(Range("A1:A100"), finden)
Set zeile = Sheets("Tabelle1").Columns("D").Find(finden, Cells(Rows.count, "D"), xlValues, xlWhole)
If Not zeile Is Nothing Then
FoundCell = zeile.Address
Do
For b = 1 To count
Set temparray(b, 1) = Sheets("Tabelle1").Cells(zeile.Row, "A").Value
Set zeile = Sheets("Tabelle1").Columns("A").Find(finden, zeile, xlValues, xlWhole)
Next b
Loop While zeile.Address <> FoundCell
End If
Set zeile = Nothing
rng.Value = temparray
Sheets("Tabelle1").Cells(1, 8 + zahl) = rng.Value
Next
End Sub
Unfortunately I already get a error message for:
set temparray(b,1)
telling me a data field was expected.
Any idea how I could solve my problem?
Have a look at the Collection object as it is a good way to store unique values. You don't need to run the multiple Find functions or incrementally build your array, you could simply read the columns once and write them into the relevant collection.
It's had to tell from your question and code how you want to write the output, but the code below will set you in the right direction:
Dim uniques As Collection
Dim valueSet As Collection
Dim valueD As String
Dim valueA As String
Dim v As Variant
Dim r As Long
Dim c As Long
Dim output() As String
'Read the data
With ThisWorkbook.Worksheets("Tabelle1")
v = .Range("A1", _
.Cells(Rows.Count, "D").End(xlUp)) _
.Value2
End With
'Populate the collections
Set uniques = New Collection
For r = 1 To UBound(v, 1)
valueA = CStr(v(r, 1))
valueD = CStr(v(r, 4))
'Check if we have a collection for the D value
Set valueSet = Nothing
On Error Resume Next
Set valueSet = uniques(valueD)
On Error GoTo 0
'If not then create a new one.
If valueSet Is Nothing Then
Set valueSet = New Collection
uniques.Add valueSet, Key:=valueD
End If
'Add the A value to it
valueSet.Add valueA
Next
'Compile the write array
ReDim Preserve output(1 To 1, 1 To uniques.Count)
c = 1
For Each valueSet In uniques
For Each v In valueSet
'--> uncomment this 'If block', if you want
'--> comma separated values.
' If Len(output(1, c)) > 0 Then
' output(1, c) = output(1, c) & ", "
' End If
output(1, c) = output(1, c) & v
Next
c = c + 1
Next
'Write the output array
ThisWorkbook.Worksheets("Tabelle1") _
.Range("H1").Resize(, UBound(output, 2)) _
.Value = output

Converting an Excel list according to row indexes

I'm trying to convert a list in Excel VBA as follows:
My original list in the one colored in grey. It shows a sequence.
I want to generate the list on the right according to each number location.
For example:
3 is second in the left list so 2 is on the third location in the right list;
6 is fourth in the left list so 4 is on the sixth location in the right list ...
I tried using 'For' loops in VBA, but it's getting a bit long and complex, is there a way to do it by using arrays in VBA?
A formula can easily achieve this. Assuming data is in A1:A8, in B1 and copied down:
=MATCH(ROW(),A$1:A$8,0)
This will work, just set the first, last and ranges as needed.
Private Sub cbSort_Click()
Dim wArray As Variant, dArray As Variant
Dim first As Integer, last As Integer
Dim i As Integer, j As Integer
first = 1
last = 8
Set wArray = Range("A" & first & ":A" & last)
ReDim dArray(1 To last - first + 1, 1 To 1)
j = 1
For i = first To last
dArray(wArray(i, 1), 1) = j
j = j + 1
Next i
Range("B" & first & ":B" & last) = dArray
End Sub
Option Explicit
Sub Main()
Dim source As Range
On Error GoTo ErrTransformIt
Set source = Application.InputBox(prompt:="Source", Type:=8)
TransformIt source
Exit Sub
ErrTransformIt:
MsgBox Err.Description
End Sub
Private Sub TransformIt(ByVal source As Range)
Dim target As Range
Dim c As Range
Dim i As Integer
Dim firstRow As Long
firstRow = source(1).Row
i = 1
For Each c In source.Cells
Set target = ActiveSheet.Cells(firstRow + c.Value - 1, c.Column + 1)
If target.Value <> "" Then
MsgBox "Target is already used by [" & target.Value & "]", vbExclamation
Exit Sub
End If
target.Value = i
i = i + 1
Next c
End Sub

Resources