I've got a spreadsheet in excel with this rows:
COLUMN
Value1.Value2.Value3
Value4.Value5.Value6
Value7.Value8.Value9
In another spreadsheet I've got a simple list with names:
COLUMN
Name1
Name2
Name3
And,of course, this list is huge :).
So need to have the following spreasdsheet at the end:
COLUMN
Value1.Name1.Value2.Value3
Value4.Name1.Value5.Value6
Value7.Name1.Value8.Value9
Value1.Name2.Value2.Value3
Value4.Name2.Value5.Value6
Value7.Name2.Value8.Value9
Value1.Name3.Value2.Value3
Value4.Name4.Value5.Value6
Value7.Name4.Value8.Value9
I have to concatenate the names on the list with all the values on spreadsheet replicating them for ALL the names.
Is there a way of doing this process automatically? The manual process would take hours to be done and I think there's a smarter way of doing that although I don't know it! :)
Thanks in advance for your help.
And it is a good challenge to do it with formulas: :)
With this array formula in D1 and then copy down
=INDEX(LEFT($A$1:$A$4;FIND(".";$A$1:$A$4))&TRANSPOSE($C$1:$C$3)&RIGHT($A$1:$A$4;LEN($A$1:$A$4)-FIND(".";$A$1:$A$4)+1);1+INT((ROWS($D$1:D1)-1)/ROWS($C$1:$C$3));1+MOD(ROWS($D$1:D1)-1;ROWS($C$1:$C$3)))
Depending on your regional settings you may need to replace field separator ";" by ","
There is always a "." between the values.
Try this code. Using arrays would be much faster for huge list of names/values:
Sub test()
Dim arrVal As Variant
Dim arrNames As Variant
Dim arrRes As Variant
Dim v, n, k As Long
'change Sheet1 to suit
With ThisWorkbook.Worksheets("Sheet1")
'change A1:A3 to values address
arrVal = .Range("A1:A3")
'change B1:B3 to names address
arrNames = .Range("B1:B3")
ReDim arrRes(1 To UBound(arrVal) * UBound(arrNames), 1 To 1)
k = 1
For Each v In arrVal
For Each n In arrNames
arrRes(k, 1) = Left(v, InStr(1, v, ".")) & n & Mid(v, InStr(1, v, "."))
k = k + 1
Next
Next v
'change "c1" to start cell where to put new values
.Range("C1").Resize(UBound(arrRes, 1)) = arrRes
End With
End Sub
Note:
If you don't know exact addresses of "values" and "name" ranges, change this part
'change A1:A3 to values address
arrVal = .Range("A1:A3")
'change B1:B3 to names address
arrNames = .Range("B1:B3")
to
'change A1:A to "values" address
arrVal = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
'change B1:B to "names" address
arrNames = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
In that case "values" and "name" ranges starts from A1 and B1 accordingly and ends in the last non empty row in coumns A and B accordingly.
Result:
I think that could work.
Const FIRST_TALBE = 4
Const SECOND_TABLE = 2
Sub makeTheJob()
For i = 1 To lastRow
l = Split(Cells(i, FIRST_TABLE), ".")
newvalue = l(0) & "." & Cells(i, SECOND_TABLE) & "." & l(1) & "." & l(2)
Debug.Print newvalue
Next i
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.
In Column A of Sheet 1, I have a list of serial numbers which contain duplicates. I want to delete all duplicates and instead come up with a history column which captures all the information of the adjacent cells with regards to that serial number. The logic of my script goes like this: 1) Filter all distinct serial numbers into a new sheet 2) For each cell in new sheet, find all matching cells in sheet 1 3) If they match then copy adjacent columns information and create an new column with new matching information 4) The more serial duplicates are, the bigger the "history" cell of that serial number is going to have
Here is a screenshot of what I'm trying to do:
https://imgur.com/a/KEn0RIP
When I use "FindPN.Interior.ColorIndex = 3", the program does fine, finding all the 1's in the column and coloring them red. I just want to copy each the 3 cells' values that are adjacent to each '1' in Column A. I have used a Dictionary to create a dynamic variable to spit out the final cell that I want, but when I run the program, I am having problems understanding how the place the variables in the FindNext loop to spit out each different B2, C2, and D2.
Sub FindPN1() 'simplified script finding all the 1's in Sheet 1
Dim I, J, K, L, Atotal As Integer
Dim FindPN, FoundPN As Range
Dim UniqueValue As Range
Dim strStatus, strDate, strComments As Object
Atotal = Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
With Sheets(1)
For I = 2 To Atotal
Set FindPN = Sheets(1).Columns(1).Find(1, LookIn:=xlValues)
If Not FindPN Is Nothing Then
Set FoundPN = FindPN
Set strStatus = CreateObject("Scripting.Dictionary")
For J = 1 To Atotal
strStatus(J) = Range("B" & I).Value
Next
Set strComments = CreateObject("Scripting.Dictionary")
For K = 1 To Atotal
strComments(K) = Range("C" & I).Value
Next
Set strDate = CreateObject("Scripting.Dictionary")
For L = 1 To Atotal
strDate(L) = Range("D" & I).Value
Next
Range("A15").Value = strDate(1)
'FindPN.Interior.ColorIndex = 3
Do
Set FindPN = .Columns(1).FindNext(After:=FindPN)
If Not FindPN Is Nothing Then
strStatus(J) = Range("B" & I).Value
strComments(K) = Range("C" & I).Value
strDate(L) = Range("D" & I).Value
'FindPN.Interior.ColorIndex = 3
Range("B15").Value = strDate(3)
If FindPN.Address = FoundPN.Address Then Exit Do
Else
Exit Do
End If
Loop
End If
Next
End With
The problem I am having is not knowing how to store my variables and having them spit out the 'History' Cell the way that I want. I have been practicing by going inside the loop to see where each variable gets defined but it seems like the strDate is always spitting out the date corresponding to the first 1.
You can make this much simpler - use a single dictionary and loop over the rows.
Add new Id's (and their "history" value) where they don't exist: if an id is already in the dictionary then append the new piece of history to the existing value.
When done, loop over the dictionary and write out the keys and the values.
Sub CombineRows()
Dim i As Long, h, k, lastRow As Long
Dim dict As Object, wsSrc As Worksheet
Set wsSrc = Sheets(1)
lastRow = wsSrc.Range("A" & Rows.Count).End(xlUp).Row
Set dict = CreateObject("Scripting.Dictionary")
For i = 2 To lastRow
With Sheets(1).Rows(i)
k = .Cells(1).Value
h = .Cells(2).Value & "|" & _
.Cells(4).Text & "|" & _
.Cells(3).Value
If dict.exists(k) Then
dict(k) = dict(k) & vbLf & h
Else
dict.Add k, h
End If
End With
Next i
DumpDict dict, Sheets(2).Range("A1")
End Sub
'write out dictionary content starting at "rng"
Sub DumpDict(dict As Object, rng As Range)
Dim c As Range, k
Set c = rng.Cells(1)
For Each k In dict.keys
c.Value = k
c.Offset(0, 1).Value = dict(k)
Set c = c.Offset(1, 0)
Next k
End Sub
I have a long list of DOM Types which have a name. For example Other, After School Activities, Arts & Culture etc. Each of these column names have a corresponding value. For example Other is 30, Aboriginal Studies is 1. What I'm trying to do is in a new column assign the proper value to each of these columns. The catch is that some columns can have multiple names separated via ;#. How would I be able to accomplish this, separating the columns with multiple names with a comma. I want it to look like this
Name Value
----- -----
Music 36
Learning Resources 32
After-School Activities;#Competitions 3,9
Assuming your names are in Column A and your values are in Column B.
This will output the split names in Column C and your split values in `Column D.
Option Explicit
Sub Work_Sub()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LR As Long, iName, iValue, iCell As Range
Dim j As Long, c As Long
LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
c = 1
For Each iCell In ws.Range("A2:A" & LR)
If InStr(iCell, ";#") Then
iName = Split(iCell, ";#")
iValue = Split(iCell.Offset(, 1), ",")
If UBound(iName) = UBound(iValue) Then
For j = LBound(iName) To UBound(iName)
ws.Range("C" & c) = iName(j)
ws.Range("D" & c) = iValue(j)
c = c + 1
Next j
Else
ws.Range("C" & c) = "Unmatched splits"
End If
iName = ""
iValue = ""
Else
iCell.Offset(0, 2).Value = iCell.Value
iCell.Offset(0, 1).Value = iCell.Offset(0, 3).Value
c = c + 1
End If
Next iCell
End Sub
Not Tested. Probably over kill - just ran with the first method that came to mind
I'm trying to build a code that looks like this:
If column D > 0 then consider all unique values from column B
and put the values in cell "A1"
The problem is that Column B has duplicated values and I just want the unique values that are greater then 0 in Column E.
Example of the worksheet
Thank you so much for your time!
You could use an array to process faster and dictionary to select distinct values.
Option Explicit
Public Sub GetDistinctValuesBasedOnCondition()
Dim inputArray(), distinctList As Object, currentItem As Long, outputString As String
Const BASE_STRING As String = "Output: "
Set distinctList = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
inputArray = .Range("B4:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
For currentItem = LBound(inputArray, 1) To UBound(inputArray, 1)
If Not distinctList.Exists(Replace$(inputArray(currentItem, 1), Chr$(32), vbNullString)) And inputArray(currentItem, 3) > 0 Then
distinctList.Add Replace$(inputArray(currentItem, 1), Chr$(32), vbNullString), 1
outputString = outputString & inputArray(currentItem, 1) & ", "
End If
Next
If Len(outputString) > 0 Then .Range("A1") = BASE_STRING & Left$(outputString, InStrRev(outputString, ", ") - 1)
End With
End Sub
It's not really clear how you want to output your unique values. Do you want the entire row? Do you just want the values from Column B? Where do you want the output?
This is a straight forward way of doing this. You could also load the values into array given your criteria (Amount > 0) then loop through your array removing duplicates (plenty of solutions on how to do that on this site)
Option Explicit
Sub Unique()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim GradeRange As Range, Grade As Range, LRow As Long
LRow = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
Set GradeRange = ws.Range("B2:B" & LRow)
For Each Grade In GradeRange
If Grade.Offset(, 2) > 0 Then
Grade.Offset(, 3) = Grade
End If
Next Grade
ws.Range("E2:E" & LRow).RemoveDuplicates 1
End Sub
I am new to macros in excel and I am trying to create one that will help me to copy data from cells from one sheet to another based on matching. Basically I want excel to look into Column H from Sheet1 and if data from any cell will match data from any cell in Column E from Sheet2, it will copy a column range from Sheet1 to Sheet2 to the relevant row (where the matching was found).
For example:
If data from H5 (sheet1) matches data from E1 (sheet2) than cells I5 to J5 (sheet1) should be copied to cells F1 to G1.
Currently I have this macro which is doing part of the job:
Sub asd()
For Counter = 1 To 10
If Sheets(1).Range("H" & Counter).Value = Sheets(2).Range("E" & Counter).Value Then
Sheets(2).Range("F" & (Counter)).Value = Sheets(1).Range("I" & Counter).Value
Sheets(2).Range("G" & (Counter)).Value = Sheets(1).Range("J" & Counter).Value
End If
Next Counter
End Sub
The problem with it is that as soon as there is no match between column H (sheet1) to column E (Sheet2) the macro stops. I am sure there is a simple way to make it jump to the next row if there is no match until all rows are done.
Can anyone edit this code to make it work?
Working under the assumption that you want your code to run for more than the first 10 lines of the two sheets, give this a try:
Sub asd()
'this runs through all used rows in sheet 1
For Counter = 1 To Sheets(1).UsedRange.Rows.Count
'this ensures that cell H<row> has a non-blank value
'you can leave this If statement out if you know there will be no blanks in Column H
If sheets(1).Range("H" & counter) <> "" then
If Sheets(1).Range("H" & Counter).Value = Sheets(2).Range("E" & Counter).Value Then
Sheets(2).Range("F" & (Counter)).Value = Sheets(1).Range("I" & Counter).Value
Sheets(2).Range("G" & (Counter)).Value = Sheets(1).Range("J" & Counter).Value
End If
End if
Next Counter
End Sub
You need 2 loops to compare the value from Sheet1 with all others in Sheet2 :
Sub asd()
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If .Cells(counterSht1, 8) = Worksheets(2).Cells(counterSht2, 5) Then
Worksheets(2).Cells(counterSht2, 6) = .Cells(counterSht1, 9)
Worksheets(2).Cells(counterSht2, 7) = .Cells(counterSht1, 10)
End If
Next counterSht2
Next counterSht1
End With
End Sub
Great guys!
Both codes are working perfectly.
There is one more thing I would need to add to it.
How can I define a range of column that need to be copied?
For e.g. instead of having this lines twice:
Sheets(2).Range("F" & (Counter)).Value = Sheets(1).Range("I" & Counter).Value
Sheets(2).Range("G" & (Counter)).Value = Sheets(1).Range("J" & Counter).Value
Or this twice
Worksheets(2).Cells(counterSht2, 6) = .Cells(counterSht1, 9)
Worksheets(2).Cells(counterSht2, 7) = .Cells(counterSht1, 10)
How can I define "I want all columns between I and AL (sheet 1) to be copied to all columns between F to AI (sheet 2)"? I have to work with 500 columns and will take a lot of time to do one line for each.
Thanks a lot!
Mihai
I have combined the two suggestions offered by FreeMan and Branislav Kollár and come up with a code that is working to also select a larger range to be copied. If anyone wants this in the future, please see below the code I got:
Sub CopyCells()
Dim lngLastRowSht1 As Long
Dim lngLastRowSht2 As Long
Dim counterSht1 As Long
Dim counterSht2 As Long
With Worksheets(1)
lngLastRowSht1 = .Cells(.Rows.Count, 8).End(xlUp).Row
lngLastRowSht2 = Worksheets(2).Cells(Worksheets(2).Rows.Count, 5).End(xlUp).Row
For counterSht1 = 1 To lngLastRowSht1
For counterSht2 = 1 To lngLastRowSht2
If Sheets(1).Range("H" & (counterSht1)).Value = Sheets(2).Range("E" & counterSht2).Value Then
Sheets(2).Range("F" & (counterSht2), "H" & (counterSht2)).Value = Sheets(1).Range("I" & counterSht1, "K" & counterSht1).Value
End If
Next counterSht2
Next counterSht1
End With
End Sub
Thanks!
Mihai