Need an Autofill VBA

[bakerman]

mrprofit
Your question is already viewed for more than 50 times and still no answer. You really need to clarify more.
It may be obvious too you but with the example file you provided and the answer you gave in Post#3 it's still difficult to figure out what you really want to achieve.(at least to me it is)

[mrprofit]

OK, thank you, please see attached file, sheet1 ~ sheet3 is the result the VBA to autofill down i needed.

[LalitPandey87]

Hi mrprofit,

Add code in Sheet3 module:

Private Sub Worksheet_Change(ByVal Target As Range)

    'Change column no accordingly
    If Target.Column = 3 Then
        Call lmp_Test
    End If


End Sub

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