' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
Option Explicit
Private Const projectUDFName = "AutoFillCells"
Private Const projectUDFVersion = "1.0"
#If VBA7 = 0 Then
Private Enum LongPtr:[_]:End Enum
#End If
#If -VBA7 And -Win64 Then
Private Declare PtrSafe Function setTimer Lib "user32" Alias "SetTimer" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function killTimer Lib "user32" Alias "KillTimer" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function setTimer Lib "user32" Alias "SetTimer" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
Private Declare PtrSafe Function killTimer Lib "user32" Alias "KillTimer" (ByVal Hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
Private Type TypeArguments
direction As Long
action As Long
Fx As String
addr As String
Cells As Excel.Range
caller As Range
FillCells As Variant
target As Excel.Range
RangeFormat As Excel.Range
RangeEvent As Excel.Range
AutoCopyFormat As Boolean
FillHorizontal As Boolean
Disabled As Boolean
End Type
Private Enum AutoFillCellsEnum
FxF_FillCells = 1
FxF_RangeFormat
FxF_AutoCopyFormat
FxF_FillHorizontal
FxF_Disabled
FxF_MainFX = 1141000
FxF_Example
End Enum
Private Work As TypeArguments
Function FxAutoFill(ByVal RangeEvent As Range, ParamArray arguments())
FxAutoFill = AddArguments(FxF_MainFX, RangeEvent, arguments)
End Function
Function FFx_FillCells(ParamArray arguments()): AddArguments FxF_FillCells, arguments: End Function
Function FFx_RangeFormat(RangeFormat As Range): AddArguments FxF_RangeFormat, RangeFormat: End Function
Function FFx_FillHorizontal(): AddArguments FxF_FillHorizontal: End Function
Function FFx_Disabled(): AddArguments FxF_Disabled: End Function
Function FxAutoFill_HuongDan(): Call AddArguments(FxF_Example): End Function
Private Function AddArguments(direction&, ParamArray arguments())
On Error Resume Next
Dim k%, i%, j%, r As Object, s$, f$, n As Boolean
Set r = Application.ThisCell:
AddArguments = "[FxAutoFill]"
If r Is Nothing Then Exit Function
Select Case direction
Case FxF_Example: FFFSetTimer direction, IIf(r Is Nothing, "", "^z"): Exit Function
End Select
f = r.Formula
s = r.Address(0, 0, , 1)
With Work
If .action = 0 Then
.action = 1
End If
Select Case direction
Case FxF_MainFX:
If r.Parent Is activeSheet And Not .Disabled Then
Set .RangeEvent = arguments(0)
Set .caller = r: .addr = s: .Fx = f
FFFSetTimer direction
Else
Dim w As TypeArguments: Work = w
End If
Case FxF_RangeFormat: Set .RangeFormat = arguments(0)
Case FxF_FillCells: .FillCells = arguments(0)
Case FxF_AutoCopyFormat: .AutoCopyFormat = True
Case FxF_FillHorizontal: .FillHorizontal = True
Case FxF_Disabled: .Disabled = True
Case Else: Exit Function
End Select
End With
End Function
Private Sub FFFSetTimer(ByVal idEvent As LongPtr, Optional keys$)
If keys <> Empty Then sendkeys keys
Call setTimer(Application.Hwnd, idEvent, 50, AddressOf FxFillAuto_callback)
End Sub
Private Sub FxFillAuto_callback(ByVal Hwnd As LongPtr, ByVal wMsg As LongPtr, ByVal idEvent As LongPtr, ByVal dwTime As LongPtr)
On Error Resume Next
killTimer Hwnd, idEvent
Select Case idEvent
Case FxF_MainFX: FxFillAuto_working
End Select
End Sub
Private Sub FxFillAuto_working()
Dim a As Object, ee As Boolean, su As Boolean, Ac As Long, b As Boolean
On Error Resume Next
GoSub st
With Work
b = AutoFillRange(.RangeEvent, .FillCells, .RangeFormat, .FillHorizontal)
End With
e:
Dim ww As TypeArguments
Work = ww
If Not a Is Nothing Then
With a
If ee And .EnableEvents <> ee Then .EnableEvents = ee
If su And .ScreenUpdating <> su Then .ScreenUpdating = su
If .Calculation <> Ac Then .Calculation = Ac
End With
If b Then Work.caller.Parent.Calculate
Set a = Nothing
End If
Exit Sub
st:
If a Is Nothing Then
Set a = Work.caller.Parent.Parent.Parent
With a
ee = .EnableEvents: If ee Then .EnableEvents = False
su = .ScreenUpdating: If su Then .ScreenUpdating = False
Ac = .Calculation: If Ac <> xlCalculationManual Then .Calculation = xlCalculationManual
End With
End If
Return
End Sub
Private Sub AutoFillRange_test()
Dim RangeEvent As Range, FillFXs(1 To 2), RangeFormat As Range, autoFormat As Boolean
Set RangeFormat = [C41:F42] ' [A5:AX6]
Set RangeEvent = [C41:C1000] '[A5:A1000]
Set FillFXs(1) = [D41:E42] ' [L5:M6]
Set FillFXs(2) = [F41:F42] '[U5:V6]
AutoFillRange RangeEvent, FillFXs, RangeFormat
'Set RangeFormat = sh.Range(RangeFormat(1, 1).MergeArea, RangeFormat)
End Sub
Private Function AutoFillRange(ByVal RangeEvent As Range, FillFXs, _
Optional ByVal RangeFormat As Range, _
Optional ByVal FillHorizontal As Boolean) As Boolean
Dim sh, rg As Range, rg1 As Range, rg2 As Range, rg3 As Range, rg0 As Range, iFXs&()
Dim lFXs%, uFXs%, fR&, i&, k&, j&, rr&, r&, fRC&, k1&, k2&, k3&, eR1&, eC&, iStep&
Dim autoFormat As Boolean, b As Boolean, e As Boolean
Set sh = RangeEvent.Parent
Set RangeEvent = sh.Range(RangeEvent(1, 1).MergeArea, RangeEvent)
lFXs = LBound(FillFXs): uFXs = UBound(FillFXs): ReDim iFXs(lFXs To uFXs, 1)
GoSub getStep
If FillHorizontal Then
Set rg0 = sh.Cells(1, fR).Resize(, iStep)
Set RangeEvent = RangeEvent.Resize(1)
eC = RangeEvent(1, 1).MergeArea.Rows.Count
Set rg = rg0(1, rg0.Columns.Count + 1).MergeArea(1, 1)
r = rg.column
rr = RangeEvent.column + RangeEvent.Columns.Count - 1
Else
Set rg0 = sh.Cells(fR, 1).Resize(iStep)
Set RangeEvent = RangeEvent.Resize(, 1)
eC = RangeEvent(1, 1).MergeArea.Columns.Count
Set rg = rg0(rg0.Rows.Count + 1, 1).MergeArea(1, 1)
r = rg.Row
rr = RangeEvent.Row + RangeEvent.Rows.Count - 1
End If
j = fRC + 1:
If iStep > 1 Then If (j Mod iStep) <> 1 Then Exit Function
Do While j <= rr
If FillHorizontal Then
Set rg = sh.Cells(RangeEvent.Row, j).MergeArea(1, 1): j = rg.column
If iStep > 1 Then k1 = iStep Else k1 = rg.MergeArea.Columns.Count
Else
Set rg = sh.Cells(j, RangeEvent.column).MergeArea(1, 1): j = rg.Row
If iStep > 1 Then k1 = iStep Else k1 = rg.MergeArea.Rows.Count
End If
e = rg.value <> Empty
For i = lFXs To uFXs
If Not FillFXs(i) Is Nothing Then
Set rg2 = FillFXs(i)
If FillHorizontal Then
Set rg2 = sh.Cells(rg2.Row, j).Resize(rg2.Rows.Count, iStep)
Else
Set rg2 = sh.Cells(j, rg2.column).Resize(iStep, rg2.Columns.Count)
End If
With rg2
b = e
If e Then
If .Rows.CountLarge = 1 And .Columns.CountLarge = 1 Then
If .value <> Empty Or .HasFormula Then b = False
Else
If Not .Find("*") Is Nothing Then b = False
End If
End If
k2 = iFXs(i, 1)
If b Then
k = 1
If k2 = 0 Then
iFXs(i, 1) = j + k1: iFXs(i, 0) = j
Else
If k2 = j Then
iFXs(i, 1) = j + k1
Else
k3 = iFXs(i, 0): iFXs(i, 0) = j: iFXs(i, 1) = j + k1: GoTo cp
End If
End If
Else
If k2 > 0 Then
k3 = iFXs(i, 0): iFXs(i, 0) = 0: iFXs(i, 1) = 0
cp:
If FillHorizontal Then
Set rg1 = sh.Cells(rg2.Row, fR).Resize(rg2.Rows.Count, iStep)
Set rg2 = sh.Cells(rg2.Row, k3).Resize(rg2.Rows.Count, k2 - k3)
Else
Set rg1 = sh.Cells(fR, rg2.column).Resize(iStep, rg2.Columns.Count)
Set rg2 = sh.Cells(k3, rg2.column).Resize(k2 - k3, rg2.Columns.Count)
End If
GoSub copy
End If
End If
End With
End If
Next
j = j + k1
If Not e Then Exit Do
Loop
If k > 0 Then
AutoFillRange = True
If Not RangeFormat Is Nothing Then
Set rg = ActiveWindow.VisibleRange
Set rg3 = ActiveCell
RangeFormat.copy
Set rg2 = RangeFormat.Resize(j - fR)
GoSub pasteFormat
rg.Select
Application.Goto rg3, False
End If
End If
Exit Function
copy:
rg1.copy rg2
Application.CutCopyMode = False
Return
pasteFormat:
rg2.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Return
getStep:
iStep = 0: fR = 0: fRC = 0
For i = lFXs To uFXs
If TypeName(FillFXs(i)) = "Range" Then
Set rg2 = FillFXs(i)
If rg2.Parent Is sh Then
If FillHorizontal Then
k2 = rg2.column
k3 = k2 + rg2.Columns.Count - 1
Else
k2 = rg2.Row
k3 = k2 + rg2.Rows.Count - 1
End If
fR = IIf(fR < k2 Or fR = 0, k2, fR)
fRC = IIf(k3 > fRC Or fRC = 0, k3, fRC)
GoTo n
End If
End If
Set FillFXs(i) = Nothing
n:
Next
Debug.Print j, fR; fRC; iStep
iStep = fRC - fR + 1
If iStep < 1 Then Exit Function
Return
End Function
