Code:
Option Explicit
Sub LMP_Test()
Dim varArrData() As Variant
Dim varArrTemp() As Variant
Dim varArrTemp1() As Variant
Dim lngLoop As Long
Dim lngIndex As Long
Dim varVal1 As Variant
Dim varVal2 As Variant
Dim strOutput As String
Const lngIDACol As Long = 2 'Change accordingly
Const lngIDBCol As Long = 3 'Change accordingly
Const lngStorCol As Long = 4 'Change accordingly
Const lngAvailCol As Long = 5 'Change accordingly
Const strDataStartCell As String = "A1" 'Change accordingly
Const strOutPutCell As String = "H1" 'Change accordingly
Const strSheetName As String = "Sheet2" 'Change accordingly
Const strConcatDelima As String = " / " 'Change accordingly
varArrData = ThisWorkbook.Worksheets(strSheetName).Range(strDataStartCell).CurrentRegion.Value
varArrTemp = varArrData
varArrTemp1 = varArrTemp
For lngLoop = LBound(varArrTemp) + 1 To UBound(varArrTemp)
'varVal1 = varArrTemp1(lngLoop, lngIDACol)
varVal2 = varArrTemp1(lngLoop, lngIDBCol)
strOutput = vbNullString
strOutput = varArrTemp1(lngLoop, lngStorCol) & IIf(strOutput <> "", strConcatDelima, "") & strOutput
DoLoop:
If varVal2 = "" Then GoTo ContinueForLoop
lngIndex = GetArrayIndex(varVal2, varArrTemp1, lngIDACol)
If lngIndex > 0 Then
strOutput = varArrTemp1(lngIndex, lngStorCol) & IIf(strOutput <> "", strConcatDelima, "") & strOutput
'varVal1 = varArrTemp1(lngIndex, lngIDACol)
varVal2 = varArrTemp1(lngIndex, lngIDBCol)
Else
lngIndex = 0
varVal1 = vbNullString
varVal2 = vbNullString
End If
lngIndex = 0
GoTo DoLoop
ContinueForLoop:
varArrTemp1(lngLoop, lngAvailCol) = strOutput
strOutput = vbNullString
Next lngLoop
With ThisWorkbook.Worksheets(strSheetName).Range(strOutPutCell)
.Resize(, UBound(varArrTemp1, 2)).EntireColumn.Clear
.Resize(UBound(varArrTemp1), UBound(varArrTemp1, 2)).Value = varArrTemp1
End With
Erase varArrData
Erase varArrTemp
Erase varArrTemp1
lngLoop = Empty
lngIndex = Empty
varVal1 = Empty
varVal2 = Empty
strOutput = vbNullString
End Sub
Function GetArrayIndex(ByVal Val As Variant, ByVal varArr As Variant, Optional lngColNo As Long = 1) As Long
Dim varDataArr As Variant
GetArrayIndex = 0
On Error Resume Next
With WorksheetFunction
varDataArr = .Index(Application.Transpose(varArr), lngColNo)
GetArrayIndex = .Match(Val, varDataArr, 0)
End With
On Error GoTo -1: On Error GoTo 0: Err.Clear
varDataArr = Empty
End Function
Reply With Quote
Originally Posted by Rick Rothstein
Bookmarks