Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (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
'//////////////////////////////////////////////////////////////
#If Win64 Then
Private Pri_TimerID As LongPtr
#Else
Private Pri_TimerID As Long
#End If
Function ArrayRotate( _
Optional ByVal Data As Range, _
Optional ByVal Rotate As Boolean = True, _
Optional ByVal ToToBo As Boolean = False, _
Optional ByVal BeToAf As Boolean = False, _
Optional ByVal LimitRow% = 0, _
Optional ByVal FromBelow As Boolean = False, _
Optional ByVal LimitCol% = 0, _
Optional ByVal FromBehind As Boolean = False, _
Optional ByVal KillOutSide As Boolean = True) As String
ArrayRotate = "ArrayRotate"
On Error Resume Next
If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
Static Caller As Range, a, b, c, d, e, f, g, h, i
If VBA.TypeName(Application.Caller) = "Range" Then
Set Caller = Application.Caller
Set Caller = Caller(2, 1)
a = Data.Value
d = UBound(a)
e = UBound(a, 2)
For i = d To 1 Step -1
For h = e To 1 Step -1
If a(i, h) <> "" Then d = i: GoTo Next1
Next
Next
Next1:
For h = e To 1 Step -1
For i = d To 1 Step -1
If a(i, h) <> "" Then e = h: GoTo ForEnd
Next
Next
ForEnd:
If d > 1 And e > 1 Then
a = Data(1, 1).Resize(d, e)
b = Rotate
c = ToToBo
d = BeToAf
e = LimitRow%
f = FromBelow
g = LimitCol%
h = FromBehind
i = KillOutSide
Pri_TimerID = SetTimer(0&, 0&, 0, AddressOf ArrayRotate_callback)
End If
Else
Dim Arr, L As Long, LngUB As Long, LngUB2 As Long
Arr = ArrayCutAndReverse(a, b, c, d, e, f, g, h, i, LngUB, LngUB2)
L = LngUB: If L < LngUB2 Then L = LngUB2
Caller.Resize(L+ 100, L + 100).ClearContents
Caller.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Set Caller = Nothing
End If
End Function
Function ArrayCutAndReverse( _
Optional ByVal Data As Variant, _
Optional ByVal Rotate As Boolean = True, _
Optional ByVal ToToBo As Boolean = False, _
Optional ByVal BeToAf As Boolean = False, _
Optional ByVal LimitRow% = 0, _
Optional ByVal FromBelow As Boolean = False, _
Optional ByVal LimitCol% = 0, _
Optional ByVal FromBehind As Boolean = False, _
Optional ByVal KillOutSide As Boolean = True, _
Optional ByVal LngUB As Long, _
Optional ByVal LngUB2 As Long) As Variant
On Error Resume Next
If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
If Not VBA.IsArray(Data) Then Exit Function
Dim R&, c%, iR&, iC%, fitR&, fitC%, UB&, UB2%, LB&, LB2%, total()
If Rotate Then Data = Application.Transpose(Data)
LB = LBound(Data, 1): LB2 = LBound(Data, 2)
UB = UBound(Data, 1): UB2 = UBound(Data, 2)
If LimitRow > 0 And LimitRow <= UB Then
iR = VBA.IIf(FromBelow, UB - LimitRow + 1, LB)
Else
iR = LB: LimitRow = UB
End If
If LimitCol > 0 And LimitCol <= UB Then
iC = VBA.IIf(FromBehind, UB2 - LimitCol + 1, LB2)
Else
iC = LB2: LimitCol = UB2
End If
ReDim total(1 To LimitRow, 1 To LimitCol)
For R = iR To VBA.IIf(FromBelow, UB, LimitRow)
fitR = VBA.IIf(ToToBo, LimitRow + iR - R, R - iR + 1)
For c = iC To VBA.IIf(FromBehind, UB2, LimitCol)
fitC = VBA.IIf(BeToAf, LimitCol + iC - c, c - iC + 1)
total(fitR, fitC) = Data(R, c)
Next c
Next R
ArrayCutAndReverse = total
End Function
Private Sub ArrayRotate_callback(): Call ArrayRotate: End Sub
