I have the below data in excel [which contains hundreds of rows]:
I am trying to find/map the words in the column "Form Word" (columnA) against the column "Form Word Orig." (columnC) and retrieve the root word which matches between "Root Results" (columnB) and "Root Results - Multiple Options" (columnD).
Note: The solution needs to find the matching ROOT from the several options (columnD) which are grouped by the Form word (columnC)
The solution would generate results something like this following:
If you could help provide a formula OR Visual Basic based solution I would be grateful.
Thank you in advance.
Try the next code, please:
Sub testFind_Mapp_Col()
Dim sh As Worksheet, arr1 As Variant, arr2 As Variant, i As Long, j As Long
Set sh = ActiveSheet 'use here your sheet
arr1 = sh.Range("A2:B" & sh.Range("A" & Rows.count).End(xlUp).Row).Value
arr2 = sh.Range("C2:E" & sh.Range("C" & Rows.count).End(xlUp).Row).Value
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i, 1) = arr2(j, 1) Then
If UCase(arr2(j, 2)) = Ucase(arr1(i, 2)) Then arr2(j, 3) = arr1(i, 2): Exit For
End If
Next j
Next i
sh.Range("C2").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
End Sub
Related
I have an excel with 2 columns,say 10 values each as given in the below diagram. The 10 values in A and B are added in a drop down in column E and column F. I want the column D, "Result", to show me 100 different possible permutations of the values again in a drop down. I tried to write a macro but getting lost somewhere. EDIT: Added the error that i am getting. any help is greatly appreciated. Example of what is expected (remember column E and F are dropdowns)
Below is the macro i have tried:
Sub Combination()
Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
arr1 = ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Value
arr2 = ws.Range("F1", ws.Range("F" & ws.Rows.Count).End(xlUp).Row).Value
ws.Range("D1").Value = "Result"
k = 1
For i = LBound(arr1, 1) To UBound(arr1, 1)
For j = LBound(arr2, 1) To UBound(arr2, 1)
ws.Range("D" & k + 1).Value = arr1(i, 1) & ", " & arr2(j, 1)
k = k + 1
If k = 101 Then Exit For
Next j
If k = 101 Then Exit For
Next i
End Sub
Debugger shows an error in this line of code:
arr1 = ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp).Row).Value
How else am i supposed to read the values in the drop down?
This task doesn't necessarily require a VBA solution: it is achievable using dynamic spreadsheet functions (if you have a relatively recent version of Excel). To my mind, people reach for VBA too readily, when it would be better to exhaust the possibilities of spreadsheet functions first.
1. Calculate the permutations
Put this formula in cell H2:
=LET(a,A2:A11,b,B2:B10,na,ROWS(a),nb,ROWS(b),s,SEQUENCE(na*nb,,0),INDEX(a,1+(INT(s/nb))) & "," & INDEX(b,1+MOD(s,nb)))
2. Set the Data Validation:
Note the # on the end of the $D$2# reference for Source. This tells Excel that the reference is to a dynamic array.
If you don't want the intermediate column displayed, then it can be Hidden or even put on another tab. Currently Excel only allows relatively simple formulae for Data Validation ranges, otherwise this column would not be needed.
Display the selections for Options A & B:
Cell E2 has the formula =LEFT(D2,FIND(",",D2)-1)
Cell F2 has the formula =RIGHT(D2,LEN(D2)-LEN(E2)-1)
You can use MATCH() to recover the index of the option in input list if required, eg =MATCH(E2,A2:A11,0) if that is needed.
Notes:
Using spreadsheet formulae rather than VBA has three benefits:
The sheet can still be saved and shared as a .xlsx file and not
.xlsm, so reducing the number of security warnings;
It is easier to see the results and test;
The sheet will update automatically (if calculation is set to Automatic), whereas a VBA macro would have to be re-run.
EDIT: An alternative, slightly more complicated formula for H2 could be:
=LET(optA,A2,optB,B2,colA,A:A,colB,B:B,
rngA,INDEX(colA,ROW(optA),,1):INDEX(colA,COUNTA(colA),ROW(optA)-1),
rngB,INDEX(colB,ROW(optB),,1):INDEX(colB,COUNTA(colB),ROW(optB)-1),
na,ROWS(rngA),nb,ROWS(rngB),s,SEQUENCE(na*nb,,0),
INDEX(rngA,1+(INT(s/nb))) & "," & INDEX(rngB,1+MOD(s,nb)))
This would handle changes to size of the Option A and Option B columns. An even more adaptive formula could use INDIRECT(), but I am against that on principle!
Answering my own question:
Wrote Macro 1:
Sub Combination1()
Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long, j As Long, k As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
arr1 = ws.Range("E1", ws.Range("E" & ws.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Value
arr2 = ws.Range("F1", ws.Range("F" & ws.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Value
ws.Range("D1").Value = "Result"
k = 1
For i = LBound(arr1, 1) To UBound(arr1, 1)
For j = LBound(arr2, 1) To UBound(arr2, 1)
ws.Range("D" & k + 1).Value = arr1(i, 1) & ", " & arr2(j, 1)
k = k + 1
If k = 101 Then Exit For
Next j
If k = 101 Then Exit For
Next i
' Add data validation to column D
With ws.Range("D2", ws.Range("D" & k).End(xlUp))
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="=" & ws.Range("D2:D" & k).Address
End With
End Sub
This basically reads the values from drop downs.
Macro 2:
Sub Combination2()
Dim arr3 As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
arr3 = ws.Range("D2", ws.Range("D" & ws.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants).Value
ws.Range("G1").Value = "Result"
For i = LBound(arr3, 1) To UBound(arr3, 1)
ws.Range("G" & i + 1).Value = arr3(i, 1)
Next i
' Add data validation to column G
With ws.Range("G2")
.Validation.Delete
.Validation.Add Type:=xlValidateList, Formula1:="=" & ws.Range("D2:D" & UBound(arr3, 1) + 1).Address
End With
' Clear values in column G except for cell G2
ws.Range("G3", ws.Range("G" & ws.Rows.Count).End(xlUp)).ClearContents
End Sub
This helps to populate the values in another dropdown
Macro 3:
Sub CombinedMacros()
Call Combination1
Call Combination2
End Sub
Happy to "help" people if they have any doubts.
I'm new using VBA and I'm trying to code into VBA but it didn't work so far, my timestamp data is not common and I got 10000+ rows to do the same formula (sometime excel just crash so i would like to try VBA)
timestamp that I tried split
Edit : add code
Sub Split_text_3()
Dim p As String
For x = 1 To 6 '---How do it until last cell?
Cells(x, 2).Value = Mid(Cells(x, 1).Value, 9, 2) 'combind in same cell
Cells(x, 3).Value = Mid(Cells(x, 1).Value, 5, 3) 'combind in same cell
Cells(x, 4).Value = Mid(Cells(x, 1).Value, 21, 4) 'combind in same cell
Cells(x, 5).Value = Mid(Cells(x, 1).Value, 12, 8)
Next x End Sub
and the data look like this (I tried to separate it first and then might try to combine them later)
image
Please, try the next function:
Function extractDateTime(strTime As String) As Variant
Dim arrD, d As Date, t As Date
arrD = Split(strTime, " ")
d = CDate(arrD(2) & "/" & arrD(1) & "/" & arrD(4))
t = CDate(arrD(3))
extractDateTime = Array(d, t)
End Function
It can be tested in the next way:
Sub testExtractDate()
Dim x As String, arrDate
x = "WED SEP 08 08:13:52 2021"
arrDate = extractDateTime(x)
Debug.Print arrDate(0), arrDate(1)
End Sub
If it returns as you need (I think, yes...), you can use the next function to process the range. It assumes that the column keeping the strings are A:A, and returns in C:D:
Sub useFunction()
Dim sh As Worksheet, lastR As Long, Arr, arrDate, arrFin, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
Arr = sh.Range("A2:A" & lastR).Value
If IsArray(Arr) Then
ReDim arrFin(1 To UBound(Arr), 1 To 2)
For i = 1 To UBound(Arr)
If Arr(i, 1) <> "" Then
arrDate = extractDateTime(CStr(Arr(i, 1)))
arrFin(i, 1) = arrDate(0): arrFin(i, 2) = arrDate(1)
End If
Next i
sh.Range("C2").Resize(UBound(arrFin), 2).Value = arrFin
Else
sh.Range("C2:D2").Value = extractDateTime(CStr(sh.Range("A2").Value))
End If
End Sub
I think I have another solution (not bulletproof) but it is simplier, quicker and code less solution (no offense FraneDuru!):
Sub DateStamp()
Dim arr, arr_temp, arr_new() As Variant
Dim i As long
'Take cells from selected all the way down to 1st blank cell
'and assign values to an array
arr = ThisWorkbook.ActiveSheet.Range(Selection, Selection.End(xlDown)).Value
ReDim Preserve arr_new(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
'Make another array by spliting input string by whitespace delimiter (default)
arr_temp = Split(arr(i, 1))
'Construct values in desired "format"
arr_new(i, 1) = "'" & arr_temp(2) & "/" & arr_temp(1) & "/" & arr_temp(4)
arr_new(i, 2) = arr_temp(3)
Next i
'Paste result into Excel
Selection.Offset(0, 1).Resize(UBound(arr), 2) = arr_new
End Sub
All you have to do is to select the cell toy want to start with and run the macro! :)
Bellow also a picture with watches, so you can catch-up what is going on:
Pretty new to all this and just giving it all a go. Just building a pet project in excel and it's coming along nicely(i'm actually midly in love with it and enjoying myself far to much!)...until i hit this wall and i'm totally stumped.
Anyway, I've hit a wall and have been search for ages to get an answer.
I'm trying to configure a vba to find duplicaates in column a(so say items). When it finds a duplicate i want it to take column b and add the sum and take column c and add the sums. All duplicates get deleted and it gets replaced/new sheet with it nice and neat. I'm tried like 100 different things, search and search and got nowhere.
This is what I want to achieve:
I'm looking at something like but it only works on summing the b column.
Dim Cl As Range
Dim Cnt As Long
With CreateObject("scripting.dictionary")
For Each Cl In Range("a1", Range("a" & Rows.Count).End(xlUp))
If Not .exists(Cl.Value) Then
.Add Cl.Value, Cl.Offset(, 1).Value
Else
.Item(Cl.Value) = .Item(Cl.Value) + Cl.Offset(, 1).Value
End If
Next Cl
Sheets("test").Range("A1").Resize(.Count).Value = Application.Transpose(.Keys)
Sheets("test").Range("B1").Resize(.Count).Value = Application.Transpose(.items)
End With
But it only works for the first column. I can't work out how to do it with the second range. Any help would be greatly appreciated.
Try this code, please:
Sub DuplicatesSum2Columns()
Dim cl As Range, arr, arrFin, El, k As Long
With CreateObject("scripting.dictionary")
For Each cl In Range("a1", Range("a" & Rows.count).End(xlUp))
If Not .Exists(cl.value) Then
.Add cl.value, cl.Offset(, 1).value & "|" & cl.Offset(, 2).value
Else
arr = Split(.item(cl.value), "|") 'split the dictionary item to load the two columns
.item(cl.value) = arr(0) + cl.Offset(, 1).value & "|" & arr(1) + cl.Offset(, 2).value
End If
Next cl
ReDim arrFin(1 To .count, 1 To 3): k = 1
'Put the dictionary keys and split items in the final array:
For Each El In .Keys
arrFin(k, 1) = El
arrFin(k, 2) = CLng(Split(.item(El), "|")(0))
arrFin(k, 3) = CLng(Split(.item(El), "|")(1))
k = k + 1
Next
'drop the array values at once:
Sheets("test").Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End With
End Sub
You could do this without VBA in O365.
E1 =UNIQUE(A1:A16)
F1 =SUMIFS(B$1:B$16,$A$1:$A$16,$E1#)
G1 =SUMIFS(B$1:B$16,$A$1:$A$16,$E1#)
Slightly misread the question, thought you wanted to sum both columns together nor separately.
Sub SumDups()
Dim dic As Object
Dim rng As Range
Dim arrDataIn() As Variant
Dim arrDataOut() As Variant
Dim arrSums() As Variant
Dim idxRow As Long
Dim ky As Variant
Set rng = Sheets("Sheet1").Range("A1").CurrentRegion
arrDataIn = rng.Value
Set dic = CreateObject("Scripting.Dictionary")
For idxRow = LBound(arrDataIn, 1) To UBound(arrDataIn, 1)
ky = arrDataIn(idxRow, 1)
If dic.Exists(ky) Then
arrSums = dic(ky)
Else
arrSums = Array(0, 0)
End If
arrSums = Array(arrSums(0) + arrDataIn(idxRow, 2), arrSums(1) + arrDataIn(idxRow, 3))
dic(ky) = arrSums
Next idxRow
ReDim arrDataOut(1 To dic.Count, 1 To 3)
idxRow = 1
For Each ky In dic.Keys
arrSums = dic(ky)
arrDataOut(idxRow, 1) = ky
arrDataOut(idxRow, 2) = arrSums(0)
arrDataOut(idxRow, 3) = arrSums(1)
idxRow = idxRow + 1
Next ky
Range("E1").Resize(dic.Count, 3).Value = arrDataOut
End Sub
How can i lookup all the data's from LOOKUP DATA and return the "House" data from LOOKUP LOCATION.I used following code but its slow and it simply pastes the array formula on cell.
.Cells(12 + i, 3).FormulaArray = "=INDEX($G:$G,MATCH(B4 & C4 & D4,$H:$H & $I:$I & $J:$J,0))"
Other ideas that i have in mind is to Concatenate the LOOKUP DATA & LOOKUP LOCATION and then use LOOKUP to get the respective data.
Are there any faster approach for looking up multiple data's using VBA ?
Here is the required code..I have used array rather than range which is faster..You can adjust outer loop if you need to find more than 3..Check this out.It's working for me..
Public Sub MultipleMatch()
Dim arr As Variant, arr2 As Variant, i As Byte, j As Long
With Sheets("Sheet4")
arr = .Range("G4:J" & .Cells(1048576, "G").End(xlUp).Row).Value
arr2 = .Range("B4:D6").Value
For i = 1 To 3
For j = LBound(arr, 1) To UBound(arr, 1)
If arr(j, 2) = arr2(i, 1) And arr(j, 3) = arr2(i, 2) And arr(j, 4) = arr2(i, 3) Then
.Cells(i + 13, 2).Value = arr(j, 1)
Exit For
End If
Next j
Next i
End With
End Sub
This should capitalize every character but I get type mismatch error.
It works fine for other worksheets that have similar data but for no reason it gives me mismatch error. Please help
Private Sub allUpper(ByRef sh As Worksheet)
Dim arr As Variant, i As Long, j As Long
If WorksheetFunction.CountA(sh.UsedRange) > 0 Then
arr = sh.UsedRange 'one interaction with the sheet
For i = 2 To UBound(arr, 1) 'each "row"
For j = 1 To UBound(arr, 2) 'each "col"
arr(i, j) = UCase(RTrim(Replace(arr(i, j), Chr(10), vbNullString)))
Next
Next
sh.UsedRange = arr 'second interaction with the sheet
End If
End Sub
You probably have an error (#N/A, etc.) somewhere in your data.
You can add a check for that to prevent the run time error:
If Not IsError(arr(i, j)) Then
arr(i, j) = UCase(RTrim(Replace(arr(i, j), Chr(10), vbNullString)))
End If