Need an Autofill VBA

I would like to use a VBA to drag and autofill the formula in D:G column, when A time and B has value correspond to C time, instead of drag and fill manually the large sum of rows. Thanks for any help

I am not understanding this

Quote:

---

when A time and B has value correspond to C time

---

Would you please explain what this means and provide several examples.

Usually i manually drag and fill down the formula to many rows, now i just want to use VBA macro to autofill just the required row only. with this book4 example, when A time 14:18 has B value (value>0), then C time 14:18 (= A time 14:18) will autofill the formula for D6:G6. For A time 14:20, B has no value, so no autofill for D7:G7. If A time has B value til 14:22, then formula will fill til D8:G8 only.

Appreciate any help

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)

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

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

---

thank you, G5 in sheet3 is empty when i apply the vba, G5 value 101.766, and E6:F9 has 0 value in it, and possible to keep the formula in the cells?

Are you asking to apply formula using vba or somthing else.
If you want formula then why need VBA just put formula and drag it till the end and whenever you put value, it will show you the output values

usig this VBA is fine, may be keep the formula in row 2 in case in future i need the formula,

In that case need to post new code.

Use this:

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)


    If Target.Column = 3 Then
        Call lmp_Test_WithFormula
    End If


End Sub

---

Code:

---

Sub lmp_Test_WithFormula()


    Dim rngData                As Range
    Dim rngFindData            As Range
    Dim rngCell                As Range


    Const strShtName            As String = "Sheet3"
    Const strDataStartCell      As String = "A2"
    Const strValueToCheckCell  As String = "C2"


    Application.Calculation = xlCalculationManual
    With ThisWorkbook
        With .Worksheets(strShtName)
            Set rngData = .Range(strDataStartCell)
            Set rngData = rngData.Resize(.Cells(.Rows.Count, rngData.Column).End(xlUp).Row)
            If WorksheetFunction.CountA(rngData) Then
                Set rngFindData = rngData.Offset(, 2)
                If WorksheetFunction.CountA(rngFindData) Then
                    For Each rngCell In rngFindData
                        rngCell.Offset(, 1).Value = vbNullString
                        If LenB(Trim(rngCell.Value)) > 0 Then
                            rngCell.Offset(, 1).FormulaArray = "=INDEX(" & rngData.Offset(, 1).Address & ", MIN(IF((" & rngData.Address & "=" & rngCell.Address(0, 1) & "),ROW(" & rngData.Address & "),""""))-1)"
                            rngCell.Offset(, 2).FormulaArray = "=MIN(IF((" & rngData.Address & "=" & rngCell.Address(0, 1) & ")," & rngData.Offset(, 1).Address & ",""""))"
                            rngCell.Offset(, 3).FormulaArray = "=MAX(IF((" & rngData.Address & "=" & rngCell.Address(0, 1) & ")," & rngData.Offset(, 1).Address & ",""""))"
                            rngCell.Offset(, 4).FormulaArray = "=INDEX(" & rngData.Offset(, 1).Address & ", MAX(IF((" & rngData.Address & "=" & rngCell.Address(0, 1) & "),ROW(" & rngData.Address & "),""""))-1)"
                        End If
                    Next rngCell
                End If
            End If
        End With
    End With
    Application.Calculation = xlCalculationAutomatic
   
    Set rngData = Nothing
    Set rngFindData = Nothing
    Set rngCell = Nothing
   
End Sub

---

the formula for max and min is misplaced, i corrected it, but the result in F5 and G5 is 0, which should be 101.66, D6:D9 should have no value nor 0, thank you for the time to help me with this,