Error when calling sub Run-Time Error '424': Object Required - excel

BIG PICTURE
Go through a list and create a tab for each item in the list (Working)
Create a hyperlink in the list that links to the associated worksheet (Working)
Create basic header information on each worksheet and hyperlink back to index sheet (Working)
Insert a button for each reference listed in a corresponding cell in the index sheet and hyperlink to that pdf, doc, or docx file (Not working, work in progress)
CURRENT PROBLEM
When calling the sub that will insert buttons I am getting an Object Required error (see image at end).
The main part of the code is as follows:
Sub CreateTabs()
Dim ws As Worksheet
Dim NameArray As Variant
Dim LastRow As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim ReferenceCount As Long
Dim RefSplit() As Variant
LastRow = FindLastRow
Set ws = ThisWorkbook.Sheets(1)
NameArray = ws.Range(ws.Cells(2, 1), ws.Cells(LastRow, 1)).Value
For x = LBound(NameArray) To UBound(NameArray)
ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = NameArray(x, 1)
'ws.Hyperlinks.Add ws.Cells(x + 1, 1), "", ThisWorkbook.Sheets(NameArray(x, 1)).Cells(1, 1).Address(External:=True), NameArray(x, 1), NameArray(x, 1)
With ThisWorkbook.Sheets(NameArray(x, 1))
ws.Hyperlinks.Add ws.Cells(x + 1, 1), "", .Cells(1, 1).Address(External:=True), .Name, .Name
.Hyperlinks.Add .Cells(1, 1), "", ws.Cells(1, 1).Address(External:=True), "Item List", "ITEM LIST"
.Cells(2, 1) = "Item"
.Cells(3, 1) = "Description"
.Cells(4, 1) = "U.O.M."
.Cells(6, 1) = "Specifications"
.Cells(2, 2).Formula = "=RIGHT(CELL(""filename"",$B$2),LEN(CELL(""filename"",$B$2))-FIND(""]"",CELL(""filename"",$B$2)))"
.Cells(3, 2).Formula = "=VLOOKUP($B$2,Sheet1!$A$2:$D$" & LastRow & ",2,0)"
.Cells(4, 2).Formula = "=VLOOKUP($B$2,Sheet1!$A$2:$D$" & LastRow & ",4,0)"
ReferenceCount = Num_Characters_In_String(ws.Cells(x + 1, 3).Value, ", ") + 1
ReDim RefSplit(1 To ReferenceCount,1)
If ReferenceCount > 1 Then
RefSplit = ReferenceSplit(ws.Cells(x + 1, 3).Value)
Else
RefSplit(1,1) = ws.Cells(x + 1, 3).Value
End If
z = 1
For y = 1 To ReferenceCount
If y > z * 5 Then z = z + 1
'*************************************************************
Call Insertbutton(z, y - (z - 1) * 5, RefSplit(y, 1).Value, ThisWorkbook.Sheets(NameArray(x, 1)))
'*************************************************************
Next y
End With
Next x
End Sub
And the sub that is being called looks as follows for now:
Sub Insertbutton(btnrow As Long, btncol As Long, btnName As String, ws As Worksheet)
Dim btn As Button
Dim rng As Range
Application.ScreenUpdating = False
ws.Buttons.Delete 'probably do not need as it is fresh sheet
Set rng = ws.Cells(btnrow + 6, btncol + 1)
Set btn = ws.Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With btn
If Left(btnName, 1) = "F" Then
If Num_Characters_In_String(btnName, "-") = 2 Then
.OnAction = "P:\2019\1234-name space\08. Working\Specifications\Section F" & btnName & "*.doc*"
Else
.OnAction = "P:\2019\1234-name space\10. Construction\01. Tender\F\" & btnName & ".pdf"
End If
Else
.OnAction = "P:\2019\1234-name space\10. Construction\01. Tender\OPSS\OPSS*" & btnName & "*.pdf"
End If
.Caption = btnName
.Name = btnName
End With
Application.ScreenUpdating = True
End Sub
QUESTION
What is the missing object? What am I doing wrong with the call?
(I foresee some issues with linking to the files but I have not got to that point in my debugging yet, and that will be a different question. Trying not to muddy the waters so to speak)
I did read this question so I believe the format of the call ( ) is correct, but I could be wrong

RefSplit(y, 1).Value causes an error. RefSplit(y, 1) is correct.
Do not use .value for arrays. Because it is used for range objects, an object error occurs.
Call Insertbutton(z, y - (z - 1) * 5, RefSplit(y, 1).Value, ThisWorkbook.Sheets(NameArray(x, 1)))
However, there is another error, and the type of the argument cannot be matched. String variables should be used.
Dim myString As String
myString = RefSplit(y, 1)
Call Insertbutton(Z, y - (Z - 1) * 5, myString, ThisWorkbook.Sheets(NameArray(x, 1)))

Related

VBA Offset Cell in left direct

I would like to transform my report into this form shown in the picture !
enter image description here
I've tried to use Offset function or dynamic assigning, but when I used to try these methods , the first row of my report was deleted.
Here is the code
Sub create_report()
Dim itemWs As Worksheet, offerWs As Worksheet, testWs As Worksheet
Dim itemLastRow As Long, offerLastRow As Long
Dim offerLastCol As Long, itemLastCol As Long
Dim dataRng As Range
Set itemWs = ThisWorkbook.Worksheets("nn_rfx_compare_per_lot")
Set offerWs = ThisWorkbook.Worksheets("Offers")
Set testWs = ThisWorkbook.Worksheets("Testowy")
itemLastRow = itemWs.Range("A" & Rows.Count).End(xlUp).Row
offerLastRow = offerWs.Range("A" & Rows.Count).End(xlUp).Row
offerLastCol = offerWs.Cells(1, Columns.Count).End(xlToLeft).Column
itemLastCol = itemWs.Cells(1, Columns.Count).End(xlToLeft).Column
Set dataRng = testWs.Range("I3:AF" & 4)
'For x = 2 To 7
'On Error Resume Next
'itemWs.Range("I" & x).Value = Application.WorksheetFunction.VLookup(itemWs.Range("C" & x).Value & itemWs.Range("B" & x).Value, dataRng, 3, 0)
'Next x
Sheets("Testowy").Range(Sheets("Testowy").Cells(offerLastCol - 1, 1), Sheets("Testowy").Cells(itemLastRow + 4, itemLastCol)) = _
Sheets("nn_rfx_compare_per_lot").Range(Sheets("nn_rfx_compare_per_lot").Cells(1, 1), Sheets("nn_rfx_compare_per_lot").Cells(itemLastRow, itemLastCol)).Value
Sheets("Testowy").Range(Sheets("Testowy").Cells(1, itemLastCol + 1), Sheets("Testowy").Cells(offerLastCol - 1, offerLastRow + itemLastCol)) = _
WorksheetFunction.Transpose(Sheets("Offers").Range(Sheets("Offers").Cells(1, 2), Sheets("Offers").Cells(offerLastRow, offerLastCol)))
Dim lastTestCol As Long
lastTestCol = testWs.Cells(1, Columns.Count).End(xlToLeft).Column
Dim ColumnLetter As String
For Row = 6 To 11
For Col = 9 To lastTestCol
On Error Resume Next
testWs.Cells(Row, Col).Value = Application.WorksheetFunction.Index(testWs.Cells( _
5, Col), Application.WorksheetFunction.Match(testWs.Cells(Row, 3).Value, testWs.Cells(3, Col), 0))
Next Col
Next Row
For Cl = 9 To lastTestCol
On Error Resume Next
testWs.Cells(5, Cl) = ""
Next Cl
End Sub

Multiple Criteria Evaluate Match Function Prohibitively Slow?

The following code successfully executes for small data sets:
Option Explicit
Option Base 1
Sub Left()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ws1, _
ws2 As Worksheet, _
wb As Workbook
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("Adj")
Set ws2 = wb.Worksheets("Deleted")
Dim a, _
b, _
i, _
j, _
k As Long
a = 957
b = 290150
Dim Item1, _
Item2, _
Arr() As Variant
With ws2
For i = 2 To a
.Cells(i, 6) = Left(.Cells(i, 1), 11)
.Cells(i, 7) = Right(.Cells(i, 1), 4)
Next i
End With
With ws1
For j = 2 To b
ReDim Preserve Arr(j - 1)
Item1 = Chr(34) & .Cells(j, 7) & Chr(34)
Item2 = Chr(34) & .Cells(j, 9) & Chr(34)
On Error Resume Next
k = Evaluate("=MATCH(1,('Deleted'!F:F = " & Item1 & ")*('Deleted'!G:G = " & Item2 & "),0)")
If Err.Number = 13 Then
Arr(j - 1) = ""
Else: Arr(j - 1) = k
End If
On Error GoTo 0
Next j
.Range(.Cells(2, 15), .Cells(b, 15)) = WorksheetFunction.Transpose(Arr())
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
However, for large data sets - such as 290,150 rows - the macro spins its wheels. It's known that Evaluate is expensive to run and I have tried running for sample sizes of 30 (success) and 1,000 (unsuccessful) and debugged carefully. Obviously in-cell array formulation drag-and-drop is not a practical alternative. So, the problem reduces to resolving endless spinning for the given multiple criteria match function required.
How do I bypass this constraint?
Try this approach using a dictionary as a lookup:
Sub Left()
Dim wsAdj As Worksheet, wsDel As Worksheet, wb As Workbook
Dim lrDel As Long, lrAdj As Long, r As Long
Dim dict, t, arr, arrG, arrI, arrRes, k
Set wb = ThisWorkbook
Set wsAdj = wb.Worksheets("Adj")
Set wsDel = wb.Worksheets("Deleted")
lrAdj = 290150
lrDel = 957
t = Timer
'load a dictionary with lookup values constructed from wsDel ColA
Set dict = CreateObject("scripting.dictionary")
arr = wsDel.Range("A2:A" & lrDel).Value
For r = 1 To UBound(arr, 1)
k = Left(arr(r, 1), 11) & Chr(0) & Right(arr(r, 1), 4)
dict(k) = r + 1 '+1 to adjust for starting at row 2
Next r
arrG = wsAdj.Range("G2:G" & lrAdj).Value 'get the match columns as arrays
arrI = wsAdj.Range("I2:I" & lrAdj).Value
ReDim arrRes(1 To UBound(arrG, 1), 1 To 1) 'resize the "result" array
'loop the values from wsAdj
For r = 1 To UBound(arrG, 1)
k = arrG(r, 1) & Chr(0) & arrI(r, 1) 'build the "key"
If dict.exists(k) Then
arrRes(r, 1) = dict(k) 'get the matched row
End If
Next r
wsAdj.Cells(2, 15).Resize(UBound(arrRes, 1), 1).Value = arrRes 'put the array on the sheet
Debug.Print "done", Timer - t ' <1 sec
End Sub
Stating Ranges instead of Columns and removing ReDim on loop helped.

SumIf in inactive worksheet and storing as array element

My aim is to SumIf in an inactive sheet, store resulting values as array elements and then transpose the array into ThisWorkBook, keeping to minimal visual and processing speed disruption.
Code:
Option Explicit
Option Base 1
Sub BM_Rebal()
Application.ScreenUpdating = False
Application.Calculation = xlManual
' Variables
Dim wb1, wb2, wb3 As Workbook
Dim ws1, ws2, ws3 As Worksheet
Dim wsf As WorksheetFunction
Dim Arr1(1 To 22), Arr2(1 To 22), Arr3(1 To 22), Arr4(1 To 22) As Variant
Dim i, j, k As Integer
Dim A, B, Path1, Path2 As String
Set wsf = Application.WorksheetFunction
Set wb3 = ThisWorkbook
Set ws3 = wb3.Sheets("Currencies")
i = 1
A = Format(ws3.Cells(1, 4), "yyyymmdd")
B = Format(ws3.Cells(1, 3), "yyyymmdd")
Path1 = "[string]" & _
"[string]" & A & ".csv"
Path2 = "[string]" & _
"[string]" & B & ".csv"
Set wb1 = Workbooks.Open(Path1)
Set wb2 = Workbooks.Open(Path2)
Set ws1 = wb1.Sheets("[string]" & A)
Set ws2 = wb2.Sheets("[string]" & B)
' Body
wb3.Activate
'wb1.Activate
With ws1
k = .UsedRange.Columns("BF").Rows.Count
For i = 1 To 22
Arr1(i) = wsf.SumIfs(.Range(.Cells(3, 58), .Cells(k, 58)), _
.Range(.Cells(3, 2), .Cells(k, 2)), ws3.Cells(1, 1), _
.Range(.Cells(3, 68), .Cells(k, 68)), ws3.Cells(i + 2, 1))
Next i
For j = i To 22
Arr2(j) = 100 * ( Arr1(j) / wsf.Sum(Arr1) )
Next j
ws1.Close
End With
'wb2.Activate
With ws2
k = .UsedRange.Columns("BF").Rows.Count
For i = 1 To 22
Arr3(i) = wsf.SumIfs(.Range(.Cells(3, 58), .Cells(k, 58)), _
.Range(.Cells(3, 2), .Cells(k, 2)), ws3.Cells(1, 1), _
.Range(.Cells(3, 68), .Cells(k, 68)), ws3.Cells(i + 2, 1))
Next i
For j = 1 To 22
Arr4(j) = 100 * ( Arr3(j) / wsf.Sum(Arr3) )
Next j
ws2.Close
End With
' Output
With ws3
.Range(.Cells(3, 3), .Cells(24,3)) = Application.Transpose(Arr2)
.Range(.Cells(3, 4), .Cells(24,4)) = Application.Transpose(Arr4)
End With
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
Which 1004 errors here:
Arr1(i) = wsf.SumIfs(.Columns("BF3:BF" & k), .Columns("B3:B" & k), .Cells(1, 1), .Columns("BP3:BP" & k), .Cells(i + 2, 1))
Now, given the msg provides no further detail other than the alert of what error type is occurring, the most likely cause was the position of (in)active sheets, but activating - bringing the relevant sheets forwards - proved unsuccessful and the syntax seems to be referencing the objects properly anyway, without the need to activate (which is ugly).
What is causing this error please?
.Columns("BF3:BF" & k) (to take one instance) should be .Range("BF3:BF" & k)
You need to use Range here instead of Columns, since you're not working with an entire column, but a subset of the column.
One can do Columns(1) or Columns("A") or Columns("A:A"), but not Columns("A1:A10").

Extract Unique Values From Multiple Columns With Macro

I have a list of codes in A and the image links in B and C.
What i want to do is remove the duplicates and arrange the unique links in a single column and give them a series name with incrementing no code_1 before image link 1 and code_2 before link 2 as shown in the picture.
I am trying this code to delete the duplicates but clueless about how to put the name before the link.
Sub tgr()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim rData As Range
Dim rArea As Range
Dim aData As Variant
Dim i As Long, j As Long
Dim hUnq As Object
'Prompt to select range. Uniques will be extracted from the range selected.
'Can select a non-contiguous range by holding CTRL
On Error Resume Next
Set rData = Application.InputBox("Select range of names where unique names will be extracted:", "Data Selection", Selection.Address, Type:=8)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'Pressed cancel
Set hUnq = CreateObject("Scripting.Dictionary")
For Each rArea In rData.Areas
If rArea.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = rArea.Value
Else
aData = rArea.Value
End If
For i = 1 To UBound(aData, 1)
For j = 1 To UBound(aData, 2)
If Not hUnq.Exists(aData(i, j)) And Len(Trim(aData(i, j))) > 0 Then hUnq(Trim(aData(i, j))) = Trim(aData(i, j))
Next j
Next i
Next rArea
Set wb = rData.Parent.Parent 'First parent is the range's worksheet, second parent is the worksheet's workbook
Set wsDest = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
wsDest.Range("A1").Resize(hUnq.Count).Value = Application.Transpose(hUnq.Items)
End Sub
This custom VBA function would create the desired result of getting the SKU code. I broke it up to show how to get each position.
Function Drop_Bucks(inputText As String) As String
Dim beginSpot As Long, endSpot As Long
'Finds last /
beginSpot = InStrRev(inputText, "/", -1, vbTextCompare) + 1
'Finds jpg
endSpot = InStrRev(inputText, ".jpg", -1, vbTextCompare)
Drop_Bucks = Replace(Mid(inputText, beginSpot, endSpot - beginSpot), "-", "_")
End Function
As a followup, you could also create the sku without VBA. If you put this formula in cell c4 with a sku in d4. It should do without macro.
=SUBSTITUTE(SUBSTITUTE(LEFT(SUBSTITUTE(SUBSTITUTE(RIGHT(SUBSTITUTE(d4, "/",REPT("?", 999)), 999),"?",""), ".jpg",REPT("?", 999)), 999),"?",""),"-","_")
This may helps you:
Option Explicit
Sub TEST()
Dim LastRow As Long, i As Long, LastRow2 As Long
Dim arr As Variant
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("$A$2:$C$" & LastRow).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arr = .Range("A2:C" & LastRow)
For i = LBound(arr) To UBound(arr)
LastRow2 = .Cells(.Rows.Count, "E").End(xlUp).Row
.Range("E" & LastRow2 + 1).Value = arr(i, 1) & "_1"
.Range("F" & LastRow2 + 1).Value = arr(i, 2)
Next i
For i = LBound(arr) To UBound(arr)
LastRow2 = .Cells(.Rows.Count, "E").End(xlUp).Row
.Range("E" & LastRow2 + 1).Value = arr(i, 1) & "_2"
.Range("F" & LastRow2 + 1).Value = arr(i, 3)
Next i
End With
End Sub
This builds a list of all the item duplicates and all. It will then uses the function Range.RemoveDuplicates to remove duplicates of the SKU Code in combination with the URL within the range.
Option Explicit
Sub Test()
Dim oCurSourceSheet As Worksheet
Set oCurSourceSheet = Sheet1 ' What sheet is your Source Data on?
Dim oSourceRow As Long ' Which Row/Column does your data start on?
oSourceRow = 2 ' First Row of First "Link"
Dim oSourceCol As Long
oSourceCol = 2 ' First Column of First "Link"
Dim oOutputRange As Range
Set oOutputRange = Sheet1.Range("A10") ' What Sheet/Cell do you want the output to start on/in?
Dim oCurRow As Long ' Row counter for Output
oCurRow = 1
Dim oCurSourceRow As Long
Dim oCurSourceCol As Long
For oCurSourceRow = oSourceRow To oCurSourceSheet.UsedRange.Rows.Count
For oCurSourceCol = oSourceCol To oCurSourceSheet.UsedRange.Columns.Count
oOutputRange.Cells(oCurRow, 1) = oCurSourceSheet.Cells(oCurSourceRow, 1) & "_" & oCurSourceCol - 1
oOutputRange.Cells(oCurRow, 2) = oCurSourceSheet.Cells(oCurSourceRow, oCurSourceCol)
oCurRow = oCurRow + 1
Next
Next
'Reize range from output's starting cell & remove duplicates
Set oOutputRange = oOutputRange.Resize(oCurRow - 1, 2)
oOutputRange.RemoveDuplicates Columns:=Array(1, 2)
End Sub
Try this, please: I adapted your code. The Dictionary is used just like a tool for avoiding duplicate values (due to the fact it exists...). Everything works in memory and should be very fast:
Option Base 1
Sub tgr_bis()
Dim wb As Workbook, rData As Range, wsDest As Worksheet, rArea As Range
Dim aData As Variant, aDataSorted() As String
Dim i As Long, hUnq As Scripting.Dictionary, nrColumns As Long
On Error Resume Next
Set rData = Application.InputBox("Select range of names where unique names will be extracted:", "Data Selection", Selection.Address, Type:=8)
On Error GoTo 0
If rData Is Nothing Then Exit Sub 'Pressed cancel
'Debug.Print rData.Columns.Count: Stop
If rData.Columns.Count > 6 Then MsgBox "More then 6 columns..." & vbCrLf & _
"Please select only six columns and run the procedure again", vbInformation, _
"Too many columns": Exit Sub
nrColumns = rData.Columns.Count
Set hUnq = CreateObject("Scripting.Dictionary")
For Each rArea In rData.Areas
If rArea.Cells.Count = 1 Then
ReDim aData(1 To 1, 1 To 1)
aData(1, 1) = rArea.value
Else
aData = rArea.value
End If
ReDim aDataSorted(nrColumns, 1)
Dim k As Long
k = 1
For i = 1 To UBound(aData, 1)
If Not hUnq.Exists(aData(i, 1)) And Len(Trim(aData(i, 1))) > 0 Then
aDataSorted(1, k) = aData(i, 1): aDataSorted(2, k) = aData(i, 2): aDataSorted(3, k) = aData(i, 3)
Select Case nrColumns
Case 4
If aData(i, 4) <> "" Then aDataSorted(4, k) = aData(i, 4)
Case 5
If aData(i, 4) <> "" Then aDataSorted(4, k) = aData(i, 4)
If aData(i, 5) <> "" Then aDataSorted(5, k) = aData(i, 5)
Case 6
If aData(i, 4) <> "" Then aDataSorted(4, k) = aData(i, 4)
If aData(i, 5) <> "" Then aDataSorted(5, k) = aData(i, 5)
If aData(i, 6) <> "" Then aDataSorted(6, k) = aData(i, 6)
Case > 6
MsgBox "Too many selected columns!": Exit Sub
End Select
k = k + 1
ReDim Preserve aDataSorted(nrColumns, k)
hUnq(Trim(aData(i, 1))) = Trim(aData(i, 1))
End If
Next i
Next rArea
'Process the new array in order to be tansformed in what is needed:
Dim finalCol() As String
k = k - 1: Z = 1
ReDim finalCol(2, Z)
Dim lngIndex As Long
Dim totalRows As Long
For i = 1 To k
lngIndex = 1
finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: lngIndex = lngIndex + 1: _
finalCol(2, Z) = aDataSorted(2, i): totalRows = totalRows + 1
Z = Z + 1: ReDim Preserve finalCol(2, Z)
finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: lngIndex = lngIndex + 1: _
finalCol(2, Z) = aDataSorted(3, i): totalRows = totalRows + 1
Z = Z + 1: ReDim Preserve finalCol(2, Z)
If nrColumns < 4 Then GoTo EndLoop
If aDataSorted(4, i) <> "" Then finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: _
lngIndex = lngIndex + 1: finalCol(2, Z) = aDataSorted(4, i): totalRows = totalRows + 1: _
Z = Z + 1: ReDim Preserve finalCol(2, Z)
If nrColumns < 5 Then GoTo EndLoop
If aDataSorted(5, i) <> "" Then finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: _
lngIndex = lngIndex + 1: finalCol(2, Z) = aDataSorted(5, i): totalRows = totalRows + 1: _
Z = Z + 1: ReDim Preserve finalCol(2, Z)
If nrColumns < 6 Then GoTo EndLoop
If aDataSorted(6, i) <> "" Then finalCol(1, Z) = aDataSorted(1, i) & "_" & lngIndex: _
lngIndex = lngIndex + 1: finalCol(2, Z) = aDataSorted(6, i): totalRows = totalRows + 1: _
Z = Z + 1: ReDim Preserve finalCol(2, Z)
EndLoop:
Next i
Set wb = rData.Parent.Parent
Set wsDest = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
wsDest.Range("A1:B" & totalRows) = Application.Transpose(finalCol)
End Sub
'A reference to "Microsoft Scripting Runtime" must be added. Otherwise, you can declare hUnq As Object...
And do not forget to have Option Base on tot of the module where this code exists. It is necessary to work with the way you built your initial code.
Edited: I adapted the code to accept up to six columns as you suggested. Please give it a try.
But it only check the unique SKU Code and select the first occurrence. If the other occurrences appear, the will not be considered even if they have different strings on its row. The code can be adapted to work also from this point of view, but now I think is your turn to make some tests...

Excel macro Help - group by

I have two columns in my excel:
TableName Function
100 abc
100 def
100 xyz
100 ghy
100 ajh
101 ahd
101 lkj
101 gtr
102 afg
102 vbg
102 arw
102 fgtr
I need output as
TableName Function
100 abc,def,xyz,ghy,ajh,
101 ahd,lkj,gtr,
102 102,102,102,102,
You can try this simpler code,
Sub joinStr()
Dim i As Long, str As String, k As Long
Columns("A:B").Sort key1:=Range("A2"), order1:=xlAscending, Header:=xlYes
str = Cells(2, 2)
k = 2
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i + 1, 1) Then
str = str & "," & Cells(i + 1, 2)
Else
Cells(k, 4) = Cells(i, 1)
Cells(k, 5) = str
k = k + 1
str = Cells(i + 1, 2)
End If
Next i
End Sub
If you are okay with VBA solution then following might help.
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim lastRow As Long
Dim dic As Variant, arr As Variant, temp As Variant
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Sheets("Sheet4") 'change Sheet4 to your data sheet
With ws
lastRow = Cells(Rows.count, "A").End(xlUp).row 'get last row with data in Column A
Set rng = .Range("A2:B" & lastRow) 'set the range of data
Set dic = CreateObject("Scripting.Dictionary")
arr = rng.Value
For i = 1 To UBound(arr, 1)
temp = arr(i, 1)
If dic.Exists(temp) Then
dic(arr(i, 1)) = dic(arr(i, 1)) & ", " & arr(i, 2)
Else
dic(arr(i, 1)) = arr(i, 2)
End If
Next
.Range("D1") = "Table Name" 'display headers
.Range("E1") = "Function"
.Range("D2").Resize(dic.count, 1) = Application.WorksheetFunction.Transpose(dic.keys) 'display table names
.Range("E2").Resize(dic.count, 1) = Application.WorksheetFunction.Transpose(dic.items) 'display funtions
End With
Application.ScreenUpdating = True
End Sub
Result will be like in the image below.
To add this code press Alt+F11 from excel. This will open Microsoft Visual Basic Editor, then click Insert > Module and paste the above code. Press F5 to execute the code.

Resources