Option Explicit
'v5
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 logFile As String
Dim fileNum As Integer
logFile = ThisWorkbook.Path & "\debug_log.txt"
fileNum = FreeFile
Open logFile For Output As #fileNum
Print #fileNum, "=== DEBUG LOG ===" & " " & Now
Print #fileNum, ""
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
Print #fileNum, "num_column (вертикальная шапка): " & num_column
If IsArray(h_arr) Then
num_row = UBound(h_arr, 2)
Print #fileNum, "num_row (горизонтальная шапка): " & num_row
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
Print #fileNum, "Горизонтальная шапка (rr): " & rr.Address
Print #fileNum, ""
' ===== РАСКРАСКА И ГРАНИЦЫ ГОРИЗОНТАЛЬНОЙ ШАПКИ =====
rr.Interior.Pattern = xlNone
Dim col_idx As Long
Dim src_col As Long, aColor As Variant
Dim cell As Range
Randomize
For col_idx = 1 To rr.Rows.count
If col_idx <= h_range.Columns.count Then
src_col = h_range.Column + col_idx - 1
' color1 = ws.Cells(6, src_col).Interior.Color
' color2 = ws.Cells(7, src_col).Interior.Color
aColor = GetCollorArray(ws.Cells(7, src_col))
ColorRow rr.Rows(col_idx), aColor, ws.Cells(6, src_col).Value = 1
' Границы для каждой ячейки в строке горизонтальной шапки
For Each cell In rr.Rows(col_idx).Cells
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
Next cell
End If
Next col_idx
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
Print #fileNum, "Вертикальная шапка (rr): " & rr.Address
Print #fileNum, ""
' ===== РАСКРАСКА И ГРАНИЦЫ ВЕРТИКАЛЬНОЙ ШАПКИ =====
rr.Interior.Pattern = xlNone
Dim row_idx As Long
For row_idx = 1 To rr.Columns.count
If row_idx <= v_range.Columns.count Then
src_col = v_range.Column + row_idx - 1
' color1 = ws.Cells(2, src_col).Interior.Color
' If ws.Cells(3, src_col).Value = 1 Then
' color2 = RGB(100 + Int((155 * Rnd) / 20) * 20, 100 + Int((155 * Rnd) / 20) * 20, 100 + Int((155 * Rnd) / 20) * 20)
' Else
' color2 = ws.Cells(3, src_col).Interior.Color
' End If
aColor = GetCollorArray(ws.Cells(2, src_col))
ColorColumn rr.Columns(row_idx), aColor
' Границы для каждой ячейки в столбце вертикальной шапки
For Each cell In rr.Columns(row_idx).Cells
With cell.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
Next cell
End If
Next row_idx
ClearBottomRange rr
' ===== ПОИСК ГРАНИЦ В СТРОКЕ 10 =====
Dim firstColBorders As Long
Dim lastColBorders As Long
Dim c As Long
Dim hasBorders As Boolean
Print #fileNum, ""
Print #fileNum, "=== ПОИСК ГРАНИЦ В СТРОКЕ 10 ==="
firstColBorders = 0
lastColBorders = 0
For c = 1 To new_ws.Columns.count
On Error Resume Next
hasBorders = (new_ws.Cells(10, c).Borders.LineStyle <> xlNone)
On Error GoTo 0
If hasBorders Then
If firstColBorders = 0 Then firstColBorders = c
lastColBorders = c
End If
Next c
If firstColBorders <> 0 And lastColBorders <> 0 Then
Print #fileNum, "Первая ячейка с границей: " & new_ws.Cells(10, firstColBorders).Address
Print #fileNum, "Последняя ячейка с границей: " & new_ws.Cells(10, lastColBorders).Address
Print #fileNum, "Диапазон в строке 10: " & new_ws.Range(new_ws.Cells(10, firstColBorders), new_ws.Cells(10, lastColBorders)).Address
Else
Print #fileNum, "Границы в строке 10 не найдены!"
End If
' ===== ПОИСК ГРАНИЦ В СТОЛБЦЕ E =====
Dim firstRowBorders As Long
Dim lastRowBorders As Long
Dim r As Long
Print #fileNum, ""
Print #fileNum, "=== ПОИСК ГРАНИЦ В СТОЛБЦЕ E ==="
firstRowBorders = 0
lastRowBorders = 0
For r = 1 To new_ws.Rows.count
On Error Resume Next
hasBorders = (new_ws.Cells(r, 5).Borders.LineStyle <> xlNone)
On Error GoTo 0
If hasBorders Then
If firstRowBorders = 0 Then firstRowBorders = r
lastRowBorders = r
End If
Next r
If firstRowBorders <> 0 And lastRowBorders <> 0 Then
Print #fileNum, "Первая ячейка с границей: " & new_ws.Cells(firstRowBorders, 5).Address
Print #fileNum, "Последняя ячейка с границей: " & new_ws.Cells(lastRowBorders, 5).Address
Print #fileNum, "Диапазон в столбце E: " & new_ws.Range(new_ws.Cells(firstRowBorders, 5), new_ws.Cells(lastRowBorders, 5)).Address
Else
Print #fileNum, "Границы в столбце E не найдены!"
End If
' ===== ЗАПОЛНЕНИЕ ПЕРЕСЕЧЕНИЯ ГРАНИЦАМИ =====
If firstColBorders <> 0 And lastColBorders <> 0 And firstRowBorders <> 0 And lastRowBorders <> 0 Then
Dim intersectRange As Range
' Пересечение: строки от firstRowBorders до lastRowBorders, столбцы от firstColBorders до lastColBorders
Set intersectRange = new_ws.Range(new_ws.Cells(firstRowBorders, firstColBorders), new_ws.Cells(lastRowBorders, lastColBorders))
Print #fileNum, ""
Print #fileNum, "=== ПЕРЕСЕЧЕНИЕ ==="
Print #fileNum, "Диапазон пересечения: " & intersectRange.Address
Print #fileNum, "Строки: " & firstRowBorders & " - " & lastRowBorders
Print #fileNum, "Столбцы: " & firstColBorders & " - " & lastColBorders
' Рисуем границы в пересечении
With intersectRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
' Внешняя рамка
With intersectRange.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With intersectRange.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With intersectRange.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
With intersectRange.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 1
End With
Print #fileNum, "Границы применены к пересечению!"
' ===== ОЧИСТКА ВСЕХ ГРАНИЦ В ЛЕВОМ СТОЛБЦЕ =====
If firstColBorders > 1 Then
Dim leftCol As Long
Dim clearRange As Range
leftCol = firstColBorders - 1
Set clearRange = new_ws.Range(new_ws.Cells(firstRowBorders, leftCol), new_ws.Cells(lastRowBorders, leftCol))
' Очищаем ВСЕ границы (полностью)
clearRange.Borders.LineStyle = xlNone
Print #fileNum, ""
Print #fileNum, "=== ОЧИСТКА ЛЕВОГО СТОЛБЦА ==="
Print #fileNum, "Очищены ВСЕ границы в столбце: " & clearRange.Address
End If
Else
Print #fileNum, ""
Print #fileNum, "=== ПЕРЕСЕЧЕНИЕ НЕ НАЙДЕНО ==="
Print #fileNum, "Не удалось найти границы в строке 10 или столбце E"
End If
Print #fileNum, ""
Print #fileNum, "=== ГОТОВО ==="
Close #fileNum
new_ws.Select
MsgBox "Готово! Лог: " & logFile, 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 ColorColumn(rr As Range, aColor As Variant)
If IsEmpty(aColor) Then Exit Sub
Dim arrY As Variant
arrY = GetNodeRows(rr)
If IsEmpty(arrY) Then Exit Sub
Dim iColor As Long
iColor = LBound(aColor)
Dim ya As Long
For ya = LBound(arrY) To UBound(arrY) Step 1
If ya + 1 <= UBound(arrY) Then
rr.Cells(arrY(ya), 1).Resize(arrY(ya + 1) - arrY(ya), 1).Interior.Color = aColor(iColor)
ElseIf ya = UBound(arrY) Then
rr.Cells(arrY(ya), 1).Resize(rr.Rows.count - arrY(ya) + 1, 1).Interior.Color = aColor(iColor)
End If
iColor = iColor + 1
If iColor > UBound(aColor) Then
iColor = LBound(aColor)
End If
Next
End Sub
Private Sub ColorRow(rr As Range, aColor As Variant, flag As Boolean)
If IsEmpty(aColor) Then Exit Sub
Dim arrY As Variant
arrY = GetNodeCols(rr)
If IsEmpty(arrY) Then Exit Sub
Dim iColor As Long
iColor = LBound(aColor)
Dim ya As Long
For ya = LBound(arrY) To UBound(arrY) Step 1
If flag Then
If rr.Cells(0, arrY(ya)) <> "" Then
iColor = LBound(aColor)
End If
End If
If ya + 1 <= UBound(arrY) Then
rr.Cells(1, arrY(ya)).Resize(1, arrY(ya + 1) - arrY(ya)).Interior.Color = aColor(iColor)
ElseIf ya = UBound(arrY) Then
rr.Cells(1, arrY(ya)).Resize(1, rr.Columns.count - arrY(ya) + 1).Interior.Color = aColor(iColor)
End If
iColor = iColor + 1
If iColor > UBound(aColor) Then
iColor = LBound(aColor)
End If
Next
End Sub
Private Function GetNodeRows(rr As Range) As Variant
Dim arr As Variant
arr = rr.Value
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ya As Long
For ya = 1 To UBound(arr, 1)
If Not IsEmpty(arr(ya, 1)) Then
dic(ya) = Empty
End If
Next
GetNodeRows = dic.Keys()
End Function
Private Function GetNodeCols(rr As Range) As Variant
Dim arr As Variant
arr = rr.Value
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ya As Long
For ya = 1 To UBound(arr, 2)
If Not IsEmpty(arr(1, ya)) Then
dic(ya) = Empty
End If
Next
GetNodeCols = dic.Keys()
End Function
Private Function GetCollorArray(cl As Range) As Variant
Dim col As Variant
col = cl.Value
Dim res As Variant
Dim rr As Range, rCol As Range
Set rCol = ThisWorkbook.Names("цвета").RefersToRange
If IsNumeric(col) Then
If col > 0 Then
Set rr = rCol.Columns(col)
End If
Else
On Error Resume Next
Set rr = rCol.Range(col & 1)
On Error GoTo 0
End If
If rr Is Nothing Then
ReDim res(0 To 1)
If cl.Interior.Color <> RGB(255, 255, 255) Then
res(0) = cl.Interior.Color
res(1) = RGB(255, 255, 255)
Else
res(0) = RGB(255, 255, 255)
res(1) = cl.Interior.Color
End If
GetCollorArray = res
Exit Function
End If
ReDim res(0 To 0)
Dim yr As Long
yr = LBound(res)
Do
res(yr) = rr.Cells(1 + yr, 1).Interior.Color
yr = yr + 1
If rr.Cells(1 + yr, 1).Interior.Color = RGB(255, 255, 255) Then Exit Do
If yr > 2 ^ 7 Then Exit Do
If yr > UBound(res) Then
ReDim Preserve res(LBound(res) To 2 * (UBound(res) + 1))
End If
DoEvents
Loop
yr = yr - 1
If yr >= LBound(res) And yr < UBound(res) Then
ReDim Preserve res(LBound(res) To yr)
End If
GetCollorArray = res
End Function
|
