Добрый день, пытаюсь свести большую матрицу в простой список, я приложил пример. В матрице по горизонтали идет город отправителя, а по вертикали город доставки, значения на пересечении городов отражают "зону сложности" отправки. Например из Абакана в Москву сложность 7, а из Москвы в Абакан 4. Мне надо эту монструозную матрицу превратить в список, на первом листе в примере нужно заполнить столбец "зоны", если делать это через ВПР, то нужно делать его по столбцу "Получатель", тогда приходиться менять номер столбца в диапазоне с возвращаемым значением под каждый новый город в столбце "Отправитель", это очень проблемно т.к. в реальности городов больше сотни, в примере их там всего 4.
С помощью чего можно упростить подстановку цифр зон из матрицы в список?
ну в целом =INDEX(Матрица!A:A;(ROW()-2)/99+3) =INDEX(Матрица!$2:$2;MOD(ROW()-2;99)+2) =INDEX(Матрица!$1:$1048576;(ROW()-2)/99+3;MOD(ROW()-2;99)+2) развернут таблицу в плоскую ну или совсем объединить все в одну =INDEX(Матрица!$1:$1048576;IF(COLUMN()=2;2;(ROW()-2)/99+3);IF(COLUMN()=1;1;MOD(ROW()-2;99)+2))
Sub Свести()
CloseEmptyWb
Dim arr As Variant
arr = GetArr(ActiveSheet, 1, 3)
If IsEmpty(arr) Then Exit Sub
Dim mrr As Variant
mrr = GetMultArr(arr)
Erase arr
OutPut mrr
End Sub
Private Sub OutPut(arr As Variant)
Dim wb As Workbook
Set wb = Workbooks.Add(1)
With wb.Sheets(1).Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2))
.Value = arr
End With
wb.Saved = True
End Sub
Private Function GetMultArr(arr As Variant) As Variant
Dim mrr As Variant
ReDim mrr(1 To UBound(arr, 1) * (UBound(arr, 1) - 1), 1 To 2)
Dim yy As Long
Dim uu As Long
Dim oo As Long
For yy = 1 To UBound(arr, 1)
For uu = 1 To UBound(arr, 1)
If yy <> uu Then
oo = oo + 1
mrr(oo, 1) = arr(yy, 1)
mrr(oo, 2) = arr(uu, 1)
End If
Next
Next
GetMultArr = mrr
End Function
Private Function GetArr(sh As Worksheet, xColumn As Long, firstRow As Long)
With sh
Dim yy As Long
yy = .Cells(.Rows.Count, xColumn).End(xlUp).Row
Dim arr As Variant
Select Case yy
Case Is < firstRow
Case firstRow
' ReDim arr(1 To 1, 1 To 1)
' arr(1, 1) = .Cells(yy, xColumn).Value
Case Else
arr = .Range(.Cells(firstRow, xColumn), .Cells(yy, xColumn))
End Select
GetArr = arr
End With
End Function
Private Sub CloseEmptyWb()
Dim wb As Workbook
For Each wb In Application.Workbooks
If wb.Path = "" Then wb.Close False
Next
End Sub
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄