Option Explicit
Option Private Module
Dim colLeft&, colRight&
'====================================================================================================
Sub FILE_Change()
Dim x, arrLeft, arrRight, arr(), r&, c&, n&, p&, flag As Boolean
arrLeft = [_allLeft].Value2: colLeft = UBound(arrLeft, 2)
arrRight = [_allRight].Value2: colRight = UBound(arrRight, 2)
ReDim arr(1 To (colLeft + colRight), 1 To 10 * UBound(arrLeft, 1))
For r = 1 To UBound(arrLeft, 1)
n = n + 1
flag = False
Call CopyRow(r, arrLeft, n, arr)
For c = 1 To colRight Step 4
If Len(arrRight(r, c)) Then
p = p + 1
If flag Then
n = n + 1
Call CopyRow(r, arrLeft, n, arr)
Call CopyPeople(r, arrRight, n, arr, c)
Else
flag = True
Call CopyPeople(r, arrRight, n, arr, c)
End If
End If
Next c
Next r
Application.ScreenUpdating = False
On Error Resume Next
[_changeFill].EntireRow.Delete
On Error GoTo 0
If p = 0 Then GoTo fin
shChange.ListObjects(1).ShowTotals = False
ReDim Preserve arr(1 To (colLeft + colRight), 1 To n)
shChange.Cells(2, 1).Resize(UBound(arr, 2), UBound(arr, 1)).Value2 = FILE_Array2xTranspose(arr)
shChange.ListObjects(1).ShowTotals = True
fin: Application.Calculate: Application.ScreenUpdating = True
If p = 0 Then Call FILE_MsgTimeWork("Списание не найдено…"): Exit Sub
Call FILE_MsgTimeWork("Найдено позиций списания: " & p & vbLf & "Таблица успешно преобразована!")
shChange.Select
End Sub
'----------------------------------------------------------------------------------------------------
Private Sub CopyRow(rFrom&, arrFrom, rWhere&, arrWhere())
Dim c&
For c = 1 To colLeft
arrWhere(c, rWhere) = arrFrom(rFrom, c)
Next c
End Sub
'----------------------------------------------------------------------------------------------------
Private Sub CopyPeople(rFrom&, arrFrom, rWhere&, arrWhere(), ByVal colStart&)
Dim c&, cc&: cc = colLeft
For c = colStart To colStart + 3
cc = cc + 1: arrWhere(cc, rWhere) = arrFrom(rFrom, c)
Next c
End Sub
'====================================================================================================
' следующие 2 находятся в другом модуле
'====================================================================================================
Function FILE_Array2xTranspose(arr2x) As Variant()
Dim arr(), r&, c&
ReDim arr(1 To UBound(arr2x, 2), 1 To UBound(arr2x, 1))
For c = 1 To UBound(arr, 2)
For r = 1 To UBound(arr, 1)
arr(r, c) = arr2x(c, r)
Next r
Next c
FILE_Array2xTranspose = arr
End Function
'====================================================================================================
Sub FILE_MsgTimeWork(Optional ByVal txtHead$ = "")
If FFF_timer = 0 Then MsgBox "Не установлено начало отсчёта", vbCritical, "FILE_MsgTimeWork": Exit Sub
If Len(txtHead) Then txtHead = txtHead & vbLf & vbLf
MsgBox txtHead & "Время работы макроса: " & Format$(Timer - FFF_timer, "0.00 сек"), vbInformation, "ГОТОВО": FFF_timer = 0
End Sub
'==================================================================================================== |