Hi mrprofit,
Add code in Sheet3 module:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
'Change column no accordingly
If Target.Column = 3 Then
Call lmp_Test
End If
End Sub
Code:
Sub lmp_Test()
Dim rngData As Range
Dim rngFindData As Range
Dim varData() As Variant
Dim varValueToCheck() As Variant
Dim varFinal() As Variant
Dim varRows As Variant
Dim objDic As Object
Dim lngLoop As Long
Dim lngLoop1 As Long
'Change these values accordingly. these values as per the attached file.
Const strShtName As String = "Sheet3"
Const strDataStartCell As String = "A2"
Const lngTotalDataColumn As Long = 2
Const strDelima As String = "|"
Const strValueToCheckCell As String = "C2"
With ThisWorkbook
With .Worksheets(strShtName)
Set rngData = .Range(strDataStartCell)
Set rngData = rngData.Resize(.Cells(.Rows.Count, rngData.Column).End(xlUp).Row, lngTotalDataColumn)
If Not rngData Is Nothing Then
If WorksheetFunction.CountA(rngData) Then
varData = rngData.Value2
Set objDic = CreateObject("Scripting.Dictionary")
objDic.CompareMode = vbTextCompare
For lngLoop = LBound(varData) To UBound(varData)
If LenB(Trim(varData(lngLoop, 1))) > 0 Then
If Not objDic.Exists(CStr(varData(lngLoop, 1))) Then
objDic.Item(CStr(varData(lngLoop, 1))) = lngLoop
Else
objDic.Item(CStr(varData(lngLoop, 1))) = objDic.Item(CStr(varData(lngLoop, 1))) & strDelima & lngLoop
End If
End If
Next lngLoop
If objDic.Count Then
If WorksheetFunction.CountA(rngData.Resize(, 1).Offset(, 2)) Then
varValueToCheck = rngData.Resize(, 1).Offset(, 2).Value2
ReDim varFinal(1 To UBound(varValueToCheck), 1 To 4)
varFinal = rngData.Resize(, 1).Offset(, 3).Resize(, 4).Value2
With .Range(strDataStartCell)
For lngLoop = LBound(varValueToCheck) To UBound(varValueToCheck)
If objDic.Exists(CStr(varValueToCheck(lngLoop, 1))) Then
varRows = objDic.Item(CStr(varValueToCheck(lngLoop, 1)))
If InStr(varRows, strDelima) = 0 Then
ReDim varRows(0 To 0)
varRows(0) = objDic.Item(CStr(varValueToCheck(lngLoop, 1)))
Else
varRows = Split(varRows, strDelima)
End If
Set rngFindData = Nothing
For lngLoop1 = LBound(varRows) To UBound(varRows)
If rngFindData Is Nothing Then
Set rngFindData = .Offset(varRows(lngLoop1) - 1, 1)
Else
Set rngFindData = Application.Union(rngFindData, .Offset(varRows(lngLoop1) - 1, 1))
End If
Next lngLoop1
'Application.Goto rngFindData
'For Opening
If Not LenB(Trim(varFinal(lngLoop, 1))) Then
varFinal(lngLoop, 1) = varData(varRows(LBound(varRows)), 2)
End If
'For High
If Not LenB(Trim(varFinal(lngLoop, 2))) Then
If Not rngFindData Is Nothing Then
varFinal(lngLoop, 2) = WorksheetFunction.Max(rngFindData)
If rngFindData.Cells.Count = 1 Then
If LenB(Trim(rngFindData.Value)) = 0 Then
varFinal(lngLoop, 2) = vbNullString
End If
End If
End If
End If
'For Low
If Not LenB(Trim(varFinal(lngLoop, 3))) Then
If Not rngFindData Is Nothing Then
varFinal(lngLoop, 3) = WorksheetFunction.Min(rngFindData)
If rngFindData.Cells.Count = 1 Then
If LenB(Trim(rngFindData.Value)) = 0 Then
varFinal(lngLoop, 3) = vbNullString
End If
End If
End If
End If
'For Close
If Not LenB(Trim(varFinal(lngLoop, 4))) Then
varFinal(lngLoop, 4) = varData(varRows(UBound(varRows)), 2)
End If
End If
If LenB(Trim(varValueToCheck(lngLoop, 1))) = 0 Then
varFinal(lngLoop, 1) = vbNullString
varFinal(lngLoop, 2) = vbNullString
varFinal(lngLoop, 3) = vbNullString
varFinal(lngLoop, 4) = vbNullString
End If
Next lngLoop
End With
With .Range(strValueToCheckCell)
.Offset(, 1).Resize(UBound(varFinal), UBound(varFinal, 2)).Value2 = varFinal
End With
End If
End If
End If
End If
End With
End With
Set rngData = Nothing
Set rngFindData = Nothing
Erase varData
Erase varValueToCheck
Erase varFinal
varRows = Empty
Set objDic = Nothing
lngLoop = Empty
lngLoop1 = Empty
End Sub
Posting Permissions
Reply With Quote
Bookmarks