Option Explicit
Sub Пересобрать()
Dim arr As Variant
arr = GetArr(ActiveSheet)
If Not IsEmpty(arr) Then
Dim brr As Variant
brr = GetBrr(arr)
Erase arr
If Not IsEmpty(brr) Then
OutArr brr
End If
End If
End Sub
Sub OutArr(arr As Variant)
With Workbooks.Add(1)
With .Sheets(1)
With .Cells(1, 1).Resize(1, UBound(arr, 2))
.Cells = Array("Страна", "Город", "Вид", "Продукт", "Дата", "Количество")
.Font.Bold = True
End With
With .Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2))
.Cells = arr
.EntireColumn.AutoFit
End With
End With
.Saved = True
End With
End Sub
Function GetBrr(arr As Variant) As Variant
If UBound(arr, 1) > 1 Then
If UBound(arr, 2) > 4 Then
Dim brr As Variant
ReDim brr(1 To (UBound(arr, 2) - 4) * (UBound(arr, 1) - 1), 1 To 6)
Dim u As Long
Dim y As Long
Dim x As Integer
Dim k As Integer
For x = 5 To UBound(arr, 2)
For y = 2 To UBound(arr, 1)
u = u + 1
For k = 1 To 4
brr(u, k) = arr(y, k)
Next
brr(u, 5) = arr(1, x)
brr(u, 6) = arr(y, x)
Next
Next
GetBrr = brr
End If
End If
End Function
Function GetArr(sh As Worksheet) As Variant
With sh
Dim y As Long
Dim x As Integer
y = .Cells(.Rows.Count, 1).End(xlUp).Row
x = .Cells(1, .Columns.Count).End(xlToLeft).Column
If y > 1 And x > 4 Then
GetArr = .Range(.Cells(1, 1), .Cells(y, x))
End If
End With
End Function
|