Need an Autofill VBA

[mrprofit]

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

[alansidman]

I am not understanding this


when A time and B has value correspond to C time

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

[mrprofit]

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.

[mrprofit]

Appreciate any help

[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

[mrprofit]

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?

[LalitPandey87]

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

[mrprofit]

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

[LalitPandey87]

In that case need to post new code.

[LalitPandey87]

Use this:



Private Sub Worksheet_Change(ByVal Target As Range)


If Target.Column = 3 Then
Call lmp_Test_WithFormula
End If


End Sub




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

[mrprofit]

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,