Страницы: 1
RSS
транспонирование масива
 
Можно ли не прибегая к макросам сделать перенос PropertyValue из таблицы на листе 1 вида
IdNamePropertyValue
6Количество мест500
6Общая площадь8693.27
6Площадь застройки2903.86
6Этажность3
6Наличие бассейнанет
6Наличие доп построекнет
6Тип фундаментамонолитный
6Тип кровлидвускатная
6Тип стенпанели ж/б
7Количество мест720
7Общая площадь11314.7
7Площадь застройки5358.5
7Этажность3
7Наличие бассейнанет
7Наличие доп построекда
7Тип фундаменталенточный
7Тип кровлидвускатная
7Тип стенкирпич
на лист 2 в таблицу вида
IdКоличество местОбщая площадьПлощадь застройкиЭтажностьНаличие бассейнаПлощадь бассейнаНаличие доп построекПлощадь   доп построекТип фундаментаТип кровлиТип стен
 
=ТРАНСП(), PQ
Согласие есть продукт при полном непротивлении сторон.

Контакты, благодарности
 
приложите файл в формате Эксель
Если в мире всё бессмысленно, — сказала Алиса, — что мешает выдумать какой-нибудь смысл? ©Льюис Кэрролл
 
Цитата
написал:
приложите файл в формате Эксель
 
Я пробовал
=ВПР(B$1;ЕСЛИ(Лист1!$A:$A=$A2;Лист1!$B:$C;"");2;ЛОЖЬ)
для использования такой формулы заполнил столбец A от 1 до 1000.
но при наличии большого количества массивов с уникальными идишниками жутко тупит.
может есть проще вариант?
Изменено: vpolshchan - 12.02.2024 13:32:32
 
Количество и расположени Name всегда одинаковые?
Если в мире всё бессмысленно, — сказала Алиса, — что мешает выдумать какой-нибудь смысл? ©Льюис Кэрролл
 
Цитата
написал:
Количество и расположени Name всегда одинаковые?
Нет. у одного Id может быть от одной строки  
 
Цитата
vpolshchan написал:
заполнил столбец A от 1 до 1000.
Тут макрос самое то
Согласие есть продукт при полном непротивлении сторон.

Контакты, благодарности
 
примерно так - сами до ума доделайте
Но за скорость не ручаюсь
 
Цитата
vpolshchan написал:
у одного Id может быть от одной строки
И это нельзя было в примере показать?
=ЕСЛИОШИБКА(ИНДЕКС(ИНДЕКС(Лист1!$B$2:$B$19;ПОИСКПОЗ($A1;Лист1!$A$2:$A$19;0)):ИНДЕКС(Лист1!$B$2:$B$19;ПОИСКПОЗ($A1;Лист1!$A$2:$A$19;0)+СЧЁТЕСЛИ(Лист1!$A$2:$A$19;$A1)-1);СТОЛБЕЦ()-1);"")
Если в мире всё бессмысленно, — сказала Алиса, — что мешает выдумать какой-нибудь смысл? ©Льюис Кэрролл
 
pq
Код
= Table.Pivot(Source, List.Distinct(Source[Name]), "Name", "PropertyValue")
Пришелец-прораб.
 
Цитата
написал:
примерно так - сами до ума доделайте Но за скорость не ручаюсь
спасибо. но не получится просто транспонировать, т.к. набор характеристик (строк на листе1) для каждого ид может быть разным
 
Какое максимальное кол-во строк (т.е. будущих столбцов) может быть у одного ID?
Согласие есть продукт при полном непротивлении сторон.

Контакты, благодарности
 
Код
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

 
?
 
Цитата
написал:
Какое максимальное кол-во строк (т.е. будущих столбцов) может быть у одного ID?
максимальное кол-во столбцов приведено на листе 2.
приложил пример со своей формулой, может нагляднее будет ожидаемый результат
 
МатросНаЗебре, здорово. спасибо огромное! работает как надо. я думал все же как-то без макроса обойтись
 
Я не хотел использовать макрос потому что не смогу в нем разобраться нормально. А мне в последующем прийдется в разных вариациях переиспользовать решение
 
Цитата
написал:
я думал все же как-то без макроса обойтись
а  чем PQ не подошел?
в исходнике у вас не все поля были для вашей таблицы. добавил и получил нужную вам.
 
Вариант:
 
R091n, отличное решение, наверное самое удобное для меня. большое спасибо
Страницы: 1
Наверх