Concatenating in Excel with special conditions Hello - I need help with the foll

Question

Concatenating in Excel with special conditions

Hello - I need help with the following:

How to create a formula/VBA that:

Looks at column A (approximately 10,000 rows), and if the rows in that column contain the same Check number (e.g 1111), then it consolidate the invoice number in the corresponding cell in column C (INVOICE_NUM, see second pic)

Example of data:

Results needed:

Once it joins all of the invoice numbers into one single cell, the repeating check numbers will be delete.

The only thing that changes is the invoice number for each check number.

THANK YOU

Explanation / Answer

Assuming that the Vendor Code in cell D9 of the initial table should have been 123456, try as follows:

Alt-F11 to open the VBA editor

Menu | Tools | References | find and check Microsoft Scripting Runtime

Alt-IM to insert a new code module

In the new module, paste the following code

'==========>>
Option Explicit

'---------->>
Public Sub Tester()
Dim WB As Workbook
Dim oDic As Scripting.Dictionary, odic2 As Scripting.Dictionary
Dim oDic3 As Scripting.Dictionary, oDic4 As Scripting.Dictionary
Dim srcSH As Worksheet, destSH As Worksheet
Dim srcRng As Range, destRng As Range
Dim arrIn As Variant, arrOut() As Variant
Dim arrKeys As Variant, arrItems As Variant
Dim i As Long, j As Long, k As Long, iKeys As Long
Dim LRow As Long
Dim vVal As Variant
Const sSheetInName As String = "Data" '<<===== Change
Const sSheetOutName As String = "Results" '<<===== Change
Dim CalcMode As Long

Set WB = ActiveWorkbook

With WB
Set srcSH = .Sheets(sSheetInName)
On Error Resume Next
Set destSH = .Sheets(sSheetOutName)
Err.Clear
If destSH Is Nothing Then
Set destSH = WB.Sheets.Add(After:=srcSH)
destSH.Name = sSheetOutName
End If
On Error GoTo 0
End With

With srcSH
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set srcRng = .Range("A2:E" & LRow)
End With

arrIn = srcRng.Value

Set oDic = New Scripting.Dictionary
Set odic2 = New Scripting.Dictionary
Set oDic3 = New Scripting.Dictionary
Set oDic4 = New Scripting.Dictionary

For i = 1 To LRow - 1
If Not oDic.Exists(arrIn(i, 1)) Then
oDic.Add Key:=arrIn(i, 1), Item:=arrIn(i, 3)
odic2.Add Key:=arrIn(i, 1), Item:=arrIn(i, 2)
oDic3.Add Key:=arrIn(i, 1), Item:=arrIn(i, 4)
oDic4.Add Key:=arrIn(i, 1), Item:=arrIn(i, 5)
Else
oDic(arrIn(i, 1)) = oDic(arrIn(i, 1)) & " " & arrIn(i, 3)
End If
Next i
arrKeys = oDic.Keys
arrItems = oDic.Items
iKeys = oDic.Count
j = UBound(arrIn, 2)
ReDim arrOut(1 To iKeys + 1, 1 To j)

For k = 1 To j
vVal = arrKeys(k - 1)
arrOut(k, 1) = vVal
arrOut(k, 2) = odic2(vVal)
arrOut(k, 3) = oDic(vVal)
arrOut(k, 4) = oDic3(vVal)
arrOut(k, 5) = oDic4(vVal)
Next k

Set destRng = destSH.Range("A2").Resize(k, j)

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With destRng
.Value = arrOut
.EntireColumn.AutoFit
srcRng.Rows(0).Copy Destination:=.Rows(0)
End With
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
Set oDic = Nothing
Set odic2 = Nothing
Set oDic3 = Nothing
Set oDic4 = Nothing

End Sub
'<<==========

Alt-Q to close the VBA editor and return to Excel

Alt-F8 to open the macro window

Select Tester | Run

Related Questions

Navigate

• Browse (All)
• Browse C
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.