Option Explicit
Sub CopyAndTranspose()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Sheets("Лист1")
Set sh2 = Sheets("Лист2")
Dim arr As Variant
arr = GetArr(sh1)
Dim xic As Object
Set xic = GetDicX(sh2)
Dim orr As Variant
orr = GetOutputArray(arr, xic)
If Not IsEmpty(orr) Then
PrintArray orr, xic.Keys(), sh2
End If
End Sub
Private Sub PrintArray(arr As Variant, hrr As Variant, sh As Worksheet)
With sh
.Cells(1, 1).Resize(, UBound(hrr) - LBound(hrr) + 1).Value = hrr
.Cells(2, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End With
End Sub
Private Function GetOutputArray(arr As Variant, xic As Object) As Variant
Dim yic As Object
Set yic = CreateObject("Scripting.Dictionary")
Dim ya As Long
For ya = 1 To UBound(arr, 1)
If arr(ya, 1) <> "" Then
If Not yic.Exists(arr(ya, 1)) Then
yic.Item(arr(ya, 1)) = yic.Count + 1
End If
End If
If arr(ya, 2) <> "" Then
If Not xic.Exists(arr(ya, 2)) Then
If xic.Count > 0 Then
xic.Item(arr(ya, 2)) = xic.Items()(xic.Count - 1) + 1
Else
xic.Item(arr(ya, 2)) = 1
End If
End If
End If
Next
If yic.Count > 0 And xic.Count > 0 Then
Dim orr As Variant
ReDim orr(1 To yic.Count, 1 To xic.Count)
Dim yo As Long
Dim xo As Long
Dim xi As Long
xi = xic.Item("id")
For ya = 1 To UBound(arr, 1)
If arr(ya, 1) <> "" Then
If arr(ya, 2) <> "" Then
yo = yic.Item(arr(ya, 1))
xo = xic.Item(arr(ya, 2))
orr(yo, xo) = arr(ya, 3)
orr(yo, xi) = arr(ya, 1)
End If
End If
Next
GetOutputArray = orr
End If
End Function
Private Function GetDicX(sh As Worksheet) As Object
With sh
Dim arr As Variant
arr = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
End With
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
Dim xa As Long
For xa = 1 To UBound(arr, 2)
If arr(1, xa) <> "" Then
dic.Item(arr(1, xa)) = xa
End If
Next
Set GetDicX = dic
End Function
Private Function GetArr(sh As Worksheet) As Variant
With sh
GetArr = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 3)).Value
End With
End Function
|
