Related
I did not know how to explain the question so I will attach images for explaining my situation. Here is the view of my Excel Sheet:
My Excel Sheet
The highlighted cells contain multiple values called ID's and are associated with respective Versions in the columns beside them. I use the following macro (details with great explanation here) to split these values into multiple rows in the same sheet.
Option Explicit
Private Const ID_IDX As Long = 0
Private Const VER_IDX As Long = 1
Private Const RNG_IDX As Long = 2
Private Sub RunMe()
Dim data As Variant, cols As Variant, items As Variant
Dim r As Long, c As Long, i As Long, n As Long
Dim ids() As String, vers() As String
Dim addItems As Collection, concatItems As Collection
Dim dataRng As Range, rng As Range
Dim writeID() As Variant, writeVer() As Variant, writeConcat() As Variant
Dim dataStartRow As Long
On Error Resume Next
'Define the range we're interested in and read into an array.
With Sheet1 'adjust for your worksheet object
Set dataRng = Application.InputBox(prompt:="Select the Range of cells:", Type:=8)
End With
data = dataRng.Value2
dataStartRow = 2
'Find the two target columns
cols = AcquireIdAndVerCol(data, 3, 8)
If IsEmpty(cols) Then
MsgBox "Unable to find Id and Ver columns."
Exit Sub
End If
With dataRng
'Add a column next to the version number column.
.Columns(cols(VER_IDX)).Offset(, 1).Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'Add a column to our range.
'This is to cover the case that the rightmost column is the version number column.
Set dataRng = .Resize(, .Columns.Count + 1)
End With
'Find the rows that need to be split and concatenate the target strings.
Set addItems = New Collection
Set concatItems = New Collection
For r = dataStartRow To UBound(data, 1)
ids = Split(data(r, cols(ID_IDX)), vbLf)
vers = Split(data(r, cols(VER_IDX)), vbLf)
n = IIf(UBound(ids) >= UBound(vers), UBound(ids), UBound(vers))
If n = 0 Then 'it's just one line of text.
'Add concatenated text to list.
concatItems.Add data(r, cols(ID_IDX)) & " " & data(r, cols(VER_IDX))
ElseIf n > 0 Then 'it's multiple lines of text.
'Transpose the id array.
ReDim writeID(1 To UBound(ids) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeID(i + 1, 1) = ids(i)
Next
'Transpose the version array.
ReDim writeVer(1 To UBound(vers) + 1, 1 To 1)
For i = 0 To UBound(ids)
writeVer(i + 1, 1) = vers(i)
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add (IIf(UBound(ids) <= n And UBound(vers) <= n, ids(i) & " " & vers(i), Empty))
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Else 'it's an empty cell
'Add empty item to concatenated list in order to keep alignment.
concatItems.Add Empty
End If
Next
Application.ScreenUpdating = False
'Split the ranges in the list.
If addItems.Count > 0 Then
For Each items In addItems
'Add the rows.
With items(RNG_IDX)
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng = .Offset(-.Rows.Count - 1).Resize(.Rows.Count + 1)
'Note: format your rng Range obect as desired here.
End With
'Write the id and version values.
rng.Columns(cols(ID_IDX)).Value = items(ID_IDX)
rng.Columns(cols(VER_IDX)).Value = items(VER_IDX)
Next
End If
'Write the concatenated values.
If concatItems.Count > 0 Then
ReDim writeConcat(1 To concatItems.Count + dataStartRow - 1, 1 To 1)
'Header to array.
writeConcat(1, 1) = "Concat values"
'Values from the collection to array.
i = dataStartRow
For Each items In concatItems
writeConcat(i, 1) = items
i = i + 1
Next
'Output array to range.
With dataRng.Columns(cols(VER_IDX) + 1)
.Value = writeConcat
.AutoFit
End With
End If
Application.ScreenUpdating = True
End Sub
Private Function AcquireIdAndVerCol(data As Variant, minCol As Long, maxCol As Long) As Variant
Dim result(1) As Long
Dim r As Long, c As Long, i As Long
Dim items() As String
'Check we're not operating outside bounds of data array.
If minCol < LBound(data, 2) Then minCol = LBound(data, 2)
If minCol > UBound(data, 2) Then minCol = UBound(data, 2)
If maxCol < LBound(data, 2) Then maxCol = LBound(data, 2)
If maxCol > UBound(data, 2) Then maxCol = UBound(data, 2)
'Loop through data to find the two columns.
'Once found, leave the function.
For r = 1 To UBound(data, 1)
For c = minCol To maxCol
items = Split(data(r, c), vbLf)
For i = 0 To UBound(items)
If result(ID_IDX) = 0 Then
If IsDocId(items(i)) Then
result(ID_IDX) = c
If result(VER_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
If result(VER_IDX) = 0 Then
If IsDocVer(items(i)) Then
result(VER_IDX) = c
If result(ID_IDX) = 0 Then
Exit For
Else
AcquireIdAndVerCol = result
Exit Function
End If
End If
End If
Next
Next
Next
End Function
Private Function IsDocId(val As String) As Boolean
Dim n As Long
n = TryClng(val)
IsDocId = (n > 9999 And n <= 999999999)
End Function
Private Function IsDocVer(val As String) As Boolean
Dim n As Long, m As Long
Dim items() As String
items = Split(val, ".")
If UBound(items) <> 1 Then Exit Function
n = TryClng(items(0))
m = TryClng(items(1))
IsDocVer = (n > 0 And n <= 99) And (m >= 0 And m <= 9)
End Function
'-------------------------------------------------------------------
'Converts a variant to a Long or returns a fail value as a Long
'if the conversion failed.
'-------------------------------------------------------------------
Private Function TryClng(expr As Variant, Optional fail As Long = -1) As Long
Dim n As Long
n = fail
On Error Resume Next
n = CLng(expr)
On Error GoTo 0
TryClng = n
End Function
It gives the following output with an addition column named, Concat Values, which contains combined values of Id's and corresponding Versions:
Output
Problem:
It works flawlessly if all the ID's have corresponding Versions specified in the sheet separately as I mentioned above. However in cases, where there is only one Version number, and it's bound to 4 or more Id's, i.e. Same Version number is applicable for all the ID's, like such:
The output in the column Concat Values gets disoriented because we are using an array to output the Concat Values and the array is not accommodating the missing Versions for corresponding Id's. It looks like this:
Dislocated row values
I am trying to learn and figure out a way to update the collection and the array with new Concat Values before Outputting it to the column, so that each Concat Value gets placed in their corresponding ID and Version location. I hope that it makes sense. Please let me know for more clarification.
EDIT:
I will try and list all the possible Cases and Expected Output, including the worst case scenarios:
Here is the link to my excel sheet.
Usual Scenarios
Number of Id's = Number of Versions (Works perfectly, Concat Values get aligned in corresponding rows in the columns)
Multiple Id's - Single Version (In such cases, the Version # applicable to all the ID's is same i.e. one Version should be applied to all the ID's.)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
Worst Case Scenarios
Multiple Id's - Multiple Versions, but less than total #ID's (In such cases, Versions should align to the topmost ID's and fill the ID's below with blanks)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
Here 4 ID's have been given only 3 Versions, so Top 3 ID's are assigned 3 Versions and the 4th ID has no Version linked to it.
Similarly,
Here 4 ID's have been given only 2 Versions, so Top 2 ID's are assigned 2 Versions and the 3rd and 4th ID's have no Version linked to them.
Multiple Id's - No Version (In such cases, columns should split into rows based on #ID's and corresponding Version rows should be filled with blanks)
Issue:
The Macro does the task of splitting the columns into rows, except the part where Concat values get misaligned.
The complexity of the solution will depend on the complexity and variety of 'special cases'. Given your scenarios, it seems as if you could just take the last of the given versions and, for any versions missing below that line, just use that last used version.
When I gave my first answer, I anticipated this kind of issue, so changes to the code are trivial.
Firstly add an additional declaration in the RunMe Sub:
Dim curVer As String
and then you just need to adjust the ElseIf n > 0 case. Replace the code with this:
ElseIf n > 0 Then 'it's multiple lines of text.
'Resize the output arrays to max ('n')
ReDim writeID(1 To n + 1, 1 To 1)
ReDim writeVer(1 To n + 1, 1 To 1)
'Loop through the arrays to align id and versions.
For i = 0 To n
If i <= UBound(ids) Then
writeID(i + 1, 1) = ids(i)
End If
If i <= UBound(vers) Then
curVer = vers(i)
End If
writeVer(i + 1, 1) = curVer
Next
'Add concatenated text to list.
For i = 0 To n
concatItems.Add writeID(i + 1, 1) & " " & writeVer(i + 1, 1)
Next
'Add the range to be split to the collection.
addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))
Too much code for me to read but I came up with my solution if I understood you problem correctly.
I guess it could be a good solution if you modify it. With my code it will be easier to produce a new table instead of adding rows I guess. Then you could just add the formatting which should be very easy.
Sub Test()
Dim xRange As Range
Dim xArrRange() As Variant
Dim xNewArrRange() As Variant
Dim xNewArrRangeResize() As Variant
Dim xNumberColumns As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim ii As Long
Dim jj As Long
Set xRange = Range("A2:C5")
xNumberColumns = 3
xArrRange = xRange.Value2
ReDim xNewArrRange(xRange.Rows.Count + 10, xNumberColumns) ' "xNumberColumns - 1" to have the number of columns
' "xNumberColumns" is one more
For i = LBound(xArrRange, 1) To UBound(xArrRange, 1)
Dim xTempArrVer As Variant
Dim xTempArrID As Variant
xTempArrVer = Split(xArrRange(i, 3), vbLf)
If UBound(xTempArrVer) = -1 Then ' If there are no version, initialize it with ""
ReDim xTempArrVer(0)
xTempArrVer(0) = ""
End If
xTempArrID = Split(xArrRange(i, 2), vbLf)
For j = LBound(xTempArrID, 1) To UBound(xTempArrID, 1)
If j > UBound(xTempArrVer, 1) Then
l = UBound(xTempArrVer, 1)
Else
l = j
End If
xNewArrRange(k, 0) = xArrRange(i, 1)
xNewArrRange(k, 1) = xTempArrID(j)
xNewArrRange(k, 2) = xTempArrVer(l)
If xTempArrVer(l) <> "" Then
xNewArrRange(k, 3) = xTempArrID(j) & " " & xTempArrVer(l)
Else
xNewArrRange(k, 3) = xTempArrID(j)
End If
k = k + 1
If k + 1 > UBound(xNewArrRange, 1) Then
ReDim Preserve xNewArrRange(UBound(xNewArrRange, 1) + 30, xNumberColumns)
End If
Next j
Next i
ReDim xNewArrRangeResize(k - 1, xNumberColumns) ' "xNumberColumns - 1" to have the number of columns
' "xNumberColumns" is one more
For ii = LBound(xNewArrRangeResize, 1) To UBound(xNewArrRangeResize, 1)
For jj = LBound(xNewArrRangeResize, 2) To UBound(xNewArrRangeResize, 2)
xNewArrRangeResize(ii, jj) = xNewArrRange(ii, jj)
Next jj
Next ii
Range(Cells(2, 6), Cells(UBound(xNewArrRangeResize, 1) + 1, 6 + UBound(xNewArrRangeResize, 2))).Value2 = xNewArrRangeResize
Debug.Print "Finish"
End Sub
This code produces this:
If your code produces good number of rows for each id etc, the most lazy solution would be just to populate columns of your table with part of my array which is produced at the end.
Edit:
I see there is something missing but that is because I calculated wrongly that Range.
Range(Cells(2, 6), Cells(UBound(xNewArrRangeResize, 1) + 1, 6 + UBound(xNewArrRangeResize, 2))).Value2 = xNewArrRangeResize
I have a problem on how to remove rows with the same values for specific Columns in excel.
Please see screenshot below for my problem:
In row 4: FullName: A SeqNo:003
In row 5: FullName: A SeqNo:003
So row 4 and 5 has the same value so I want to remove one of them but I don't want to remove row automatically by random but in condition that only the latest date will remain.
Condition be like this:
This should be the correct output:
So how can I achieve this by macro vba?
Thanks in advance!
Try this.
Sub test()
Dim vDB, vR()
Dim X As New Collection
Dim Str As String
Dim i As Long, j As Long, r As Long, c As Integer
Dim n As Long
vDB = Range("a1").CurrentRegion
r = UBound(vDB, 1)
c = UBound(vDB, 2)
On Error Resume Next
For i = 1 To r
Str = vDB(i, 1) & vDB(i, 4)
Err.Clear
X.Add Str, Str
If Err.Number = 0 Then
n = n + 1
ReDim Preserve vR(1 To c, 1 To n)
For j = 1 To c
vR(j, n) = vDB(i, j)
Next j
End If
Next i
For i = 1 To n
For j = 1 To r
If vDB(j, 1) = vR(1, i) And vDB(j, 4) = vR(4, i) Then
If vDB(j, 5) >= vR(5, i) Then
vR(2, i) = vDB(j, 2)
vR(5, i) = vDB(j, 5)
End If
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(n, c) = WorksheetFunction.Transpose(vR)
End Sub
Record a macro of you sorting by the date column newest to oldest, then using the remove duplicates feature on the three columns but untick the date column in the remove duplicates dialogue. By default Excel keeps the first duplicate it comes to so by sorting you will remove the rows with older dates.
You should be able to tidy up the recorded code yourself.
I'm struggling to write the correct code to be able to Copy and Paste Values for non-blank values with matching criteria.
An example of what I'm trying to do can be seen here (Example)
What I would like the code to do is to take the values in the left hand range that are not blank, and paste the values into the right hand range where they match according to the labels in row A.
If the new values could paste as a highlighted color that would be helpful as well; however, my main struggle is mainly with the first part. (Picture of how it would look after the macro has run) - (Answer)
I have been able to figure this out by using excel formulas within my code; however, this is not ideal for the functionality of my workbook.
Thanks for the help! - It's much appreciated.
Update:
Sub Button2_Click()
Worksheets("Nielson").Range("AH3:CD9999").Formula = "=if(NOT(ISBLANK(vlookup($a3,Load!$P:$AD,Load!R$4,False))),iferror(vlookup($a3,Load!$P:$AD,Load!R$4,False),ch3),ch3)"
Worksheets("Nielson").Range("AH3:CD9999").Copy
Worksheets("Nielson").Range("CH3:CT9999").PasteSpecial xlPasteValues Worksheets("Nielson").Range("CH3:CT9999").Copy
Worksheets("Nielson").Range("AH3:CD9999").PasteSpecial xlPasteValues
End Sub
(code posted as comment by OP)
This can help you. Is a modification of this code.
Private Sub Button2_Click()
Dim vReplacementArray() As Variant
Dim iLastRowReplacements As Integer
Dim iLastRowData As Integer
Dim i As Integer, j As Integer, r As Integer, c As Integer
Dim ValToFind1 As String
iLastRowReplacements = Worksheets("Nielson").Cells(Rows.Count, 1).End(xlUp).Row
iLastRowData = Worksheets("Nielson").Cells(Rows.Count, 9).End(xlUp).Row
'Create an array with replacement data (left 6 columns in your example)
For i = 2 To iLastRowReplacements
ReDim Preserve vReplacementArray(1 To 6, 1 To i)
'You can loop here. I leave it hard-coded to make it clearer
vReplacementArray(1, i) = Worksheets("Nielson").Cells(i, 1).Value
vReplacementArray(2, i) = Worksheets("Nielson").Cells(i, 2).Value
vReplacementArray(3, i) = Worksheets("Nielson").Cells(i, 3).Value
vReplacementArray(4, i) = Worksheets("Nielson").Cells(i, 4).Value
vReplacementArray(5, i) = Worksheets("Nielson").Cells(i, 5).Value
vReplacementArray(6, i) = Worksheets("Nielson").Cells(i, 6).Value
Next
For i = 2 To iLastRowData 'Scan all rows with data, starting in row 2 (row 1 for titles)
'Get values from column I (ValToFind1)
ValToFind1 = Worksheets("Nielson").Cells(i, 9).Value
'Find those to values in the array, and write the replacement in their respective column
For c = 1 To UBound(vReplacementArray, 2)
If (vReplacementArray(1, c) = ValToFind1) Then
For j = 1 To 5 'The five columns (J to N in your example)
If (vReplacementArray(j + 1, c) <> "") Then 'if there is a value
Worksheets("Nielson").Cells(i, 9 + j).Value = vReplacementArray(j + 1, c)
Worksheets("Nielson").Cells(i, 9 + j).Interior.ColorIndex = 4
End If
Next j
End If
Next c
Next i
End Sub
I'm definitely a beginner when it comes to VBA beyond editing other peoples Macros. I have a project I'm working on where I need to combine data taken from the first pivot row and column headers and paste it in a new worksheet.
I need to take the row values in column A (which can be variable in data and count) multiply each row by the number of columns (also can be variable in data and count) such that if I have 3 columns (A,B,C) and two rows(1,2) before the macro after I will have 6 rows and 3 columns with the first 3 rows all having the same data as the original row 1 and the second 3 rows with the same data as the original row 2.
Then I have to paste down the columns to match the rows as well as the data to match the row and columns.
Original Pivot:
Goal After Macro:
I know I need to count the number of columns declare that a variable and then use that variable to copy the rows over to the new worksheet using a loop. I don't believe using a second pivot will work as it wont use the column header a cell value even if I do a tabular view. I've tried writing some code but I cant get to it as I'm on my home computer.
Any advise on how to get past the first part of having it count the number of columns and expand the rows would be much appreciated.
Here you go. This should do what you are looking for. You will just need to set the value of Sheet2("A1") manually to Accnt..
TESTED:
Private Sub FormShift()
Dim tRow As Long 'target Row
Dim lastCol As Long
Dim lastRow As Long
lastCol = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
tRow = 2
For iRow = 2 To lastRow
For iCol = 2 To lastCol
Sheets("Sheet2").Cells(tRow, 1) = Sheets("Sheet1").Cells(iRow, 1)
Sheets("Sheet2").Cells(tRow, 2) = Sheets("Sheet1").Cells(1, iCol)
Sheets("Sheet2").Cells(tRow, 3) = Sheets("Sheet1").Cells(iRow, iCol)
tRow = tRow + 1
Next iCol
Next iRow
End Sub
Sub horz_vert()
noOfColumns = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column - 1
noOfRows = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row - 1
Worksheets("Sheet2").Cells(1, 1) = Worksheets("Sheet1").Cells(1, 1)
For j = 1 To noOfRows
For I = 1 To noOfColumns
Worksheets("Sheet2").Cells((I + 1) + (j - 1) * noOfColumns, 1) = Worksheets("Sheet1").Cells(j + 1, 1)
Worksheets("Sheet2").Cells((I + 1) + (j - 1) * noOfColumns, 2) = Worksheets("Sheet1").Cells(1, I + 1)
Worksheets("Sheet2").Cells((I + 1) + (j - 1) * noOfColumns, 3) = Worksheets("Sheet1").Cells(j + 1, I + 1)
Next
Next
End Sub
I'm trying to figure out a way to combine rows based on values in two specific columns in vba excel.
For Example:
Let's say I have the following sheet:
Column A Column J Column Z
1 A ?
1 A !
2 B ?
2 B !
And I need to convert it to this:
Column A Column J Column Z
1 A ?, !
2 B ?, !
Here's another method using User Defined Types and collections to iterate through the list and develop the combined results. For large sets of data, it should be considerably faster than reading through each cell on the worksheet.
I assume that you are grouping on Col J, and that Column A data does not need to be concatenated in the cell. If it does, the modifications to the routine would be trivial.
First, Insert a Class Module, rename it CombData and insert the following code into that module:
Option Explicit
Private pColA As String
Private pColJ As String
Private pColZConcat As String
Public Property Get ColA() As String
ColA = pColA
End Property
Public Property Let ColA(Value As String)
pColA = Value
End Property
Public Property Get ColJ() As String
ColJ = pColJ
End Property
Public Property Let ColJ(Value As String)
pColJ = Value
End Property
Public Property Get ColZConcat() As String
ColZConcat = pColZConcat
End Property
Public Property Let ColZConcat(Value As String)
pColZConcat = Value
End Property
Then Insert a Regular Module and insert the Code Below:
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1").Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
EDIT: Note that the source data is read into the Variant array V. If you examine V in the Watch Window, you will see that the first dimension represents the rows; and the second dimension the columns. So if you wanted, for example, to perform the same procedure on a different set of columns, you would merely change the references to the second dimension under the line that reads Set cCombData = New CombData. For example, column B data would be V(I,2), and so forth. Of course, you might want to rename the data types to make them more representative of what you are doing.
In addition, if your data starts at row 2, merely start the iteration through V with I = 2 instead of I = 1.
EDIT2: In order to both overwrite the original, and also maintain the contents of the columns not being processed, the following modification will do that for Columns A, J and Z. You should be able to modify it for whatever columns you choose to process.
Option Explicit
Sub CombineData()
Dim cCombData As CombData
Dim colCombData As Collection
Dim V As Variant
Dim vRes() As Variant 'Results Array
Dim rRes As Range 'Location of results
Dim I As Long, J As Long, K As Long
'read source data into array
V = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=26)
'Set results range. Here it is set below the Source Data
'Could be anyplace, even on a different worksheet; or could overlay the
' original. Area below and to right is cleared
Set rRes = Range("A1") '.Offset(UBound(V) + 10)
Range(rRes, rRes.SpecialCells(xlCellTypeLastCell)).Clear
Set colCombData = New Collection
On Error Resume Next
For I = 1 To UBound(V)
Set cCombData = New CombData
cCombData.ColA = V(I, 1)
cCombData.ColJ = V(I, 10)
cCombData.ColZConcat = V(I, 26)
colCombData.Add cCombData, CStr(cCombData.ColJ)
If Err.Number <> 0 Then
Err.Clear
With colCombData(cCombData.ColJ)
.ColZConcat = .ColZConcat & ", " & V(I, 26)
End With
End If
Next I
On Error GoTo 0
ReDim vRes(1 To colCombData.Count, 1 To 26)
For I = 1 To UBound(vRes)
With colCombData(I)
vRes(I, 1) = .ColA
vRes(I, 10) = .ColJ
vRes(I, 26) = .ColZConcat
'Note the 10 below is the column we are summarizing by
J = WorksheetFunction.Match(.ColJ, WorksheetFunction.Index(V, 0, 10), 0)
For K = 1 To 26
Select Case K 'Decide which columns to copy over
Case 2 To 9, 11 To 25
vRes(I, K) = V(J, K)
End Select
Next K
End With
Next I
rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) = vRes
End Sub
This is assuming that Column J is the key and Column A doesn't need to be appended. If Column A needs to be combined as well (not always the same), you would simply need to add another for each loop to check if the data is there, and add it if not, as done for col 26 in the code.
Sub CombineData()
x = 2
Do Until Cells(x, 1) = "" 'loop through every row in sheet starting at 2 (1 will never be removed, since it is the first data)
x2 = 1
Do Until x2 = x
If Cells(x, 10) = Cells(x2, 10) Then 'this is comparing column J. If another column is the reference then change 10 to the column number
splt = Split(Cells(x, 26), ", ")
For Each s In splt 'check to see if data already in column z
If s = Cells(x2, 26) Then GoTo alreadyEntered
Next
Cells(x, 26) = Cells(x, 26) & ", " & Cells(x2, 26) 'append column z data to row x
alreadyEntered:
Rows(x2).Delete Shift:=xlUp 'delete duplicate row
x = x - 1 'to keep x at same row, since we just removed a row
Exit Do
Else
x2 = x2 + 1
End If
Loop
x = x + 1
Loop
End Sub