Option Explicit
'v4
Public Sub makeTable()
Dim ws As Worksheet, new_ws As Worksheet
Set ws = Worksheets("3464743")
Set new_ws = Worksheets("Лист1")
Const vert_rng As String = "L4"
Const hor_rng As String = "L5"
Const target_rng As String = "E10"
Const delim = ","
Dim v_range As Range, h_range As Range
With ws
Set v_range = .Range(vert_rng, .Cells(.Range(vert_rng).Row, .Columns.count).End(xlToLeft))
Set h_range = .Range(hor_rng, .Cells(.Range(hor_rng).Row, .Columns.count).End(xlToLeft))
End With
Dim v_arr As Variant, h_arr As Variant
v_arr = v_range.Value
h_arr = h_range.Value
Dim count As Long
count = 1
Dim out_arr() As Variant
Dim i As Long, num_column As Long, num_row As Long
Dim d As Variant
Dim rr As Range
If IsArray(v_arr) Then
num_column = UBound(v_arr, 2)
Else
num_column = 1
End If
Application.ScreenUpdating = False
Dim Application_Calculation As XlCalculation: Application_Calculation = Application.Calculation: Application.Calculation = xlCalculationManual
Application.Calculation = Application_Calculation
If IsArray(h_arr) Then
num_row = UBound(h_arr, 2)
ReDim out_arr(1 To row_count(h_arr), 1 To UBound(h_arr, 2))
For i = UBound(h_arr, 2) To LBound(h_arr, 2) Step -1
count = count * (UBound(Split(h_arr(1, i), delim), 1) + 1)
fill_arr h_arr(1, i), out_arr, i, count
Next i
d = Application.Transpose(out_arr)
new_ws.Range(target_rng).Offset(0, num_column + 1).Resize(UBound(d, 1), UBound(d, 2)).Value = d
Set rr = new_ws.Range(target_rng).Offset(0, num_column + 1).Resize(UBound(d, 1) - 1, UBound(d, 2))
Else
d = Split(h_arr, delim)
num_row = 1
new_ws.Range(target_rng).Offset(0, num_column + 1).Resize(1, UBound(d, 1) + 1).Value = Application.Transpose(d)
Set rr = new_ws.Range(target_rng).Offset(0, num_column + 1).Resize(1, UBound(d, 1) + 1)
End If
rr.Interior.Pattern = xlNone
For i = 1 To h_range.Columns.count
If (h_range.Cells(2, i).Interior.Color <> RGB(255, 255, 255)) Or (v_range.Cells(3, i).Interior.Color <> RGB(255, 255, 255)) Then
ColorRange rr, Array(i, i, 1, rr.Columns.count, h_range.Cells(2, i).Interior.Color, h_range.Cells(3, i).Interior.Color)
End If
Next
ClearBottomRange rr
count = 1
If IsArray(v_arr) Then
ReDim out_arr(1 To row_count(v_arr), 1 To UBound(v_arr, 2))
For i = UBound(v_arr, 2) To LBound(v_arr, 2) Step -1
count = count * (UBound(Split(v_arr(1, i), delim), 1) + 1)
fill_arr v_arr(1, i), out_arr, i, count
Next i
new_ws.Range(target_rng).Offset(num_row + 1, 0).Resize(UBound(out_arr, 1), UBound(out_arr, 2)).Value = out_arr
Set rr = new_ws.Range(target_rng).Offset(num_row + 1, 0).Resize(UBound(out_arr, 1), UBound(out_arr, 2))
Else
d = Split(v_arr, delim)
new_ws.Range(target_rng).Offset(num_row + 1, 0).Resize(UBound(d, 1) + 1, 1).Value = d
Set rr = new_ws.Range(target_rng).Offset(num_row + 1, 0).Resize(UBound(d, 1) + 1, 1)
End If
rr.Interior.Pattern = xlNone
For i = 1 To v_range.Columns.count
If (v_range.Cells(0, i).Interior.Color <> RGB(255, 255, 255)) Or (v_range.Cells(-1, i).Interior.Color <> RGB(255, 255, 255)) Then
ColorRange rr, Array(1, rr.Rows.count, i, i, v_range.Cells(0, i).Interior.Color, v_range.Cells(-1, i).Interior.Color)
End If
Next
ClearBottomRange rr
new_ws.Select
Application.Calculation = Application_Calculation
Application.ScreenUpdating = True
MsgBox "Готово", vbInformation, "makeTable"
End Sub
Private Function row_count(arr As Variant, Optional delim As String = ",") As Long
Dim i As Long, result As Long
result = 1
For i = UBound(arr, 2) To LBound(arr, 2) Step -1
result = result * (UBound(Split(arr(1, i), delim), 1) + 1)
Next i
row_count = result
End Function
Private Sub fill_arr(arr As Variant, new_arr() As Variant, ind As Long, count As Long, Optional delim As String = ",")
Dim i As Long, result As Long, n As Long, k As Long, d As Long
Dim txt As Variant, el As Variant
txt = Split(arr, delim)
d = UBound(txt, 1) + 1
For i = LBound(new_arr, 1) To UBound(new_arr, 1) Step count
n = count / d
For k = 0 To (count - 1) Step n
new_arr(i + k, ind) = txt(k \ n)
Next k
Next i
End Sub
Private Sub ClearBottomRange(rr As Range)
Set rr = rr.Cells(rr.Rows.count + 1, 1)
Set rr = rr.Resize(rr.Parent.UsedRange.Rows.count, rr.Parent.UsedRange.Columns.count)
rr.Clear
End Sub
Private Sub ColorRange(rr As Range, ParamArray arr() As Variant)
Dim vv As Variant
For Each vv In arr
ColorRowCol rr, vv(0), vv(1), vv(2), vv(3), vv(4), vv(5)
Next
End Sub
Private Sub ColorRowCol(rr As Range, ByVal rowMin As Long, ByVal rowMax As Long, ByVal colMin As Long, ByVal colMax As Long, ByVal color1 As Long, ByVal color2 As Long)
Dim arrNode As Variant
arrNode = GetNode(rr, rowMin, rowMax, colMin, colMax)
If IsEmpty(arrNode) Then Exit Sub
Dim iColor As Byte, arrColor As Variant
arrColor = Array(color1, color2)
Dim ya As Long, rBeg As Range, rEnd As Range, rOut As Range, nodeBeg As Variant, nodeEnd As Variant
For ya = LBound(arrNode) To UBound(arrNode) - 1
nodeBeg = arrNode(ya)
nodeEnd = arrNode(ya + 1)
Set rBeg = rr.Cells(nodeBeg(0), nodeBeg(1))
Set rEnd = rr.Cells(nodeEnd(0), nodeEnd(1))
Set rOut = Range(rBeg, rEnd)
rOut.Interior.Color = arrColor(iColor)
iColor = 1 - iColor
Next
End Sub
Private Function GetNode(rr As Range, rowMin As Long, rowMax As Long, colMin As Long, colMax As Long) As Variant
Dim arr As Variant
arr = rr.Value
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ya As Long, xa As Long
For ya = rowMin To rowMax
For xa = colMin To colMax
If Not IsEmpty(arr(ya, xa)) Then
GoTo addDicItem
Else
If ya = rowMin Then
If xa = colMin Then
GoTo addDicItem
End If
End If
If ya = rowMax Then
If xa = colMax Then
GoTo addDicItem
End If
End If
End If
GoTo nextRow
addDicItem:
dic(ya & " " & xa) = Array(ya, xa)
nextRow:
Next
Next
GetNode = dic.Items()
End Function
|
