Option Explicit
Sub Redesigner_V2()
' Данное решение построено на массивах, авторство принадлежит МСН (http://www.excelworld.ru).
' Внес небольшую коррективу, а именно запрос на выделение диапазона - Максим Зеленский, с дружеского форума (http://www.planetaexcel.ru).
' Дополнительные улучшения и полезности - SLAVICK (http://www.excelworld.ru)
' Небольшие дополнения и коррективы - DJ Marker MC (http://www.excelworld.ru).
Dim inpdata As Range, realdata As Range, ns As Worksheet
Dim i&, ii&, c&, r&, hc&, hr&, nSt&, nT&
Dim out(), dataArr(), hcArr(), hrArr(), shapka ', shapkaFirst As Boolean
Dim shParam As Worksheet
Set shParam = Worksheets("Данные для Макроса")
On Error GoTo line1
Set inpdata = Application.InputBox("Выберите обрабатываемый диапазон:", "Выбор диапазона", Selection.Address, Type:=8)
' hr = InputBox("Сколько строк с подписями данных сверху", , 1)
' hc = InputBox("Сколько столбцов с подписями данных слева?", , 1)
' nSt = InputBox("Сколько столбцов с данными будет в правой части таблицы? (например: если Ваша таблица уходит вправо на 24 месяца то указав тут 12 - месяцы разобьются по столбцам, а год перенесется по строкам", , 1)
hr = shParam.Range("B2")
hc = shParam.Range("B3")
nSt = shParam.Range("B4")
' Проверка шапки если nSt = 1
If nSt = 1 And hr > 1 Then
If MsgBox("Выбрано только один столбец повторения, уменьшить шапку?", vbYesNo) = vbYes Then
shapka = inpdata.Cells(hr, 1).Resize(1, hc).Value 'realdata.Value
Else
shapka = inpdata.Resize(hr, hc).Value 'realdata.Value
End If
Else
shapka = inpdata.Resize(hr, hc).Value 'realdata.Value
End If
Application.ScreenUpdating = False
If inpdata.Rows.Count <= hr Or inpdata.Columns.Count <= hc Then Exit Sub
Set realdata = inpdata.Offset(hr, hc).Resize(inpdata.Rows.Count - hr, inpdata.Columns.Count - hc)
dataArr = realdata.Value
If hr Then hrArr = inpdata.Offset(0, hc).Resize(hr, inpdata.Columns.Count - hc).Value
If hc Then hcArr = inpdata.Offset(hr, 0).Resize(inpdata.Rows.Count - hr, hc).Value
' Проверка шапки
For i = 1 To UBound(hrArr)
For ii = 1 To UBound(hrArr, 2)
hrArr(i, ii) = Проверка_слова(CStr(hrArr(i, ii)))
Next ii, i
' Проверка справочника
For i = 1 To UBound(hcArr)
For ii = 1 To UBound(hcArr, 2)
hcArr(i, ii) = Проверка_слова(CStr(hcArr(i, ii)))
Next ii, i
'====================================
ReDim out(1 To realdata.Count / nSt, 1 To hr + hc + nSt)
'Начало основного цикла
hr = 0
For i = 1 To UBound(hcArr)
hc = 1
For ii = 1 To Int(UBound(dataArr, 2) / nSt)
hr = hr + 1
For r = 1 To UBound(hrArr): out(hr, r) = hrArr(r, hc): Next r
For c = 1 To UBound(hcArr, 2): out(hr, c + r - 1) = hcArr(i, c): Next c
For nT = 1 To nSt
' Добавление данных если не ошибка
If Not IsError(dataArr(i, hc)) Then out(hr, c + r + nT - 2) = dataArr(i, hc)
hc = hc + 1
Next
Next
Next
' Set ns = Worksheets.Add ' Добавление листа
Set ns = Worksheets(shParam.Range("B5"))
If IsArrayEmpty(shapka) = False Then
ns.Cells(1, r).Resize(UBound(shapka), UBound(shapka, 2)) = shapka
If nSt = 1 Then ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = "Значения" Else ns.Cells(1, r + c - 1).Resize(UBound(shapka), nSt) = hrArr ' Выгрузка шапки столбцов
r = UBound(shapka) + 1
Else
ns.Cells(1, r) = shapka ' Выгрузка шапки строк
If nSt = 1 Then ns.Cells(1, r + c - 1) = "Значения" Else ns.Cells(1, r + c - 1).Resize(UBound(hrArr), nSt) = hrArr ' Выгрузка шапки столбцов
r = 2
End If
ns.Cells(r, 1).Resize(UBound(out), UBound(out, 2)) = out ' Выгрузка данных
'Удобности:
ns.Cells(1, 1).Resize(r - 1, UBound(out, 2)).Interior.ColorIndex = 44 ' Закрашивание шапки
ns.Cells(r, UBound(hrArr) + c).Select: ActiveWindow.FreezePanes = True ' Закрепление шапки
ns.Range(Cells(r - 1, 1), Cells(UBound(out), UBound(out, 2))).AutoFilter ' Установка Автофильтра
' Установка границ
With ns.Range(Cells(1, 1), Cells(Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row, UBound(out, 2))).Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
Application.ScreenUpdating = True
line1:
End Sub
Private Function Проверка_слова(str As String)
If Len(str) = 1 Then Проверка_слова = str: Exit Function
If IsError(str) = True Then Проверка_слова = "": Exit Function
If Not IsDate(str) And Not IsNumeric(str) Then Проверка_слова = str: Exit Function
If Left(str, 2) = "0," Then Проверка_слова = str * 1: Exit Function
If Left(str, 1) = "0" Then Проверка_слова = "'" & str: Exit Function
If InStr(1, str, "-") > 0 Then Проверка_слова = "'" & str: Exit Function
If InStr(1, str, ".") > 0 Then Проверка_слова = "'" & str: Exit Function
If InStr(1, str, "/") > 0 Then Проверка_слова = "'" & str: Exit Function
If IsNumeric(str) Then Проверка_слова = str * 1 Else Проверка_слова = str
End Function
Function IsArrayEmpty(anArray As Variant) As Boolean
On Error GoTo IS_EMPTY
If (UBound(anArray) >= 0) Then Exit Function
IS_EMPTY:
IsArrayEmpty = True
End Function
|