Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 68551 Skopiuj do schowka Przekonwertowanie tabeli
Autor Wiadomość
oval
forumowicz


Posty: 15
Wysłany: 20-07-2020, 10:27   Przekonwertowanie tabeli

Witam,

Nie mam pomysłu w jaki sposób mogę przekonwertować tabelę, tak żeby spełniała moje wymagania. Opis słowny byłby dosyć ciężki do napisania, więc wrzucam plik z przykładowymi danymi i przykładową tabelą wyjściową.
Dane do tabeli wejściowej będą zaciągał przy pomocy PowerQuerry ze strony internetowej i wykorzystywał tę samą tabelę do wielu innych obliczeń, więc wolałbym gdyby ona sama została w niezmienionej formie.

Z góry dziękuję za wszelkie wskazówki.

przykład.xlsx
Pobierz Plik ściągnięto 16 raz(y) 9.46 KB

ID posta: 389904 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 720 razy
Posty: 3878
Wysłany: 20-07-2020, 19:09   

Makro - zakręcone: żonglerka komórkami - ale działa.

Info:
1. Założyłem że na 1 login przypada zawsze 5 wierszy.
2. Kod sprawdza ten warunek.
3. Pod tabelą, w kol A nie może być żadnych wypełnionych komórek. Uwaga: pusta "optycznie" komórka nie oznacza że Excel nie widzi tam wartości - dla pewności należy usunąć całe wiersze.
4 "Dla pewności" kod usuwa poprzednie dane do wiersza 1000 (wystarczy?).
.

Kopia przykład.xlsm
Pobierz Plik ściągnięto 6 raz(y) 21.31 KB

_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
Ostatnio zmieniony przez umiejead 20-07-2020, 21:43, w całości zmieniany 1 raz  
ID posta: 389949 Skopiuj do schowka
 
 
kuma 
Excel Expert


Wersja: Win Office 2010
Pomógł: 1394 razy
Posty: 3996
Wysłany: 20-07-2020, 21:41   

Może moja konwersja będzie Ci odpowiadała.
Podałeś dane, które nie zawsze muszą być takie regularne. Dla każdego Id i loginu dane (inputy) są posortowane od A-Z.
Wstaw nowy arkusz --> nazwij go 'Arkusz2' --> do modułu normalnego VBA skopiuj poniższy kod i uruchom.
Kod:
Sub ConvertTable()
    Dim a(), at(), af, k
    Dim i As Long, ii As Long
    Dim j As Integer
    Dim d As Object, lst As Object
    Dim ms As String
   
    Set d = CreateObject("Scripting.Dictionary")
    Set lst = CreateObject("System.Collections.ArrayList")
    With Sheets("Arkusz1")
        a = .[A2].CurrentRegion.Value
        With d
            For i = 2 To UBound(a)
                ms = a(i, 1) & "|" & a(i, 2)
                For j = 3 To UBound(a, 2)
                    If Len(a(i, j)) = 0 Then GoTo end_
                    If .exists(ms) Then
                        at = .Item(ms)
                        ii = UBound(at) + 1
                        ReDim Preserve at(1 To ii)
                        at(ii) = a(i, j)
                        .Item(ms) = at
                    Else
                        ReDim at(1 To 1)
                        at(1) = a(i, j)
                        .Item(ms) = at
                    End If
                Next j
            Next
        End With
    End With
end_:
    With Sheets("Arkusz2")
        .UsedRange.ClearContents
        .[A1].Resize(, 2) = Application.Index(a, 1, Array(1, 2))
        For Each k In d.keys
            af = d.Item(k)
            For i = 1 To UBound(af)
                lst.Add af(i)
            Next
            lst.Sort
            With .Range("A" & .Cells(Rows.Count, "A").End(3).Row)(2)
                .Value = Split(k, "|")(0)
                .Offset(0, 1).Value = Split(k, "|")(1)
                .Offset(0, 2).Resize(, lst.Count) = lst.toarray
            End With
            lst.Clear
        Next
    End With
    Set d = Nothing
    Set lst = Nothing
End Sub
_________________
Pozdrawiam.
ID posta: 389958 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 720 razy
Posty: 3878
Wysłany: 20-07-2020, 21:53   

No to @kuma ci napisał cały program... :). BTW: sam PQ nie potrafi tego zrobić?

BTW.: "PQ" = "Power Query"
Po literce: "P" > "o" > "w" .... :mrgreen: .
.
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 389960 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9951
Wysłany: 21-07-2020, 00:42   

Też trochę poćwiczyłem palce.
Jedno założenie: loginy występują grupami.
Liczba wierszy dla każdego loginu jest bez znaczenia. Komórki puste są pomijane.
Kod:
Sub TranspozycjaTabeli()
    Dim dicLogins   As Object
    Dim dicData     As Object
    Dim i           As Long
    Dim lColCnt     As Long
    Dim lDataCnt    As Long
    Dim lIdsCnt     As Long
    Dim w           As Long
    Dim lKeysCnt    As Long
    Dim vData       As Variant
    Dim oLstObj     As ListObject
    Dim wksNew      As Worksheet
    Dim vIds()      As Variant
    Dim Key         As Variant
    Dim vResult     As Variant

    Set oLstObj = ActiveSheet.ListObjects(1)
    On Error Resume Next
    'pobierz dane z tabeli do tablicy
    vData = oLstObj.DataBodyRange.Value
    On Error GoTo 0

    If IsEmpty(vData) Then Exit Sub

    Set dicLogins = CreateObject("Scripting.Dictionary")

    w = 0

    'biegaj po wierszach tablicy
    For i = 1 To UBound(vData)
        'twórz słownik unikalnych loginów (w Keys-ach) i liczbę wystąpień (w Items-ach)
        'oraz ID każdego loginu w tablicy vIds
        If Not dicLogins.Exists(vData(i, 2)) Then
            ReDim Preserve vIds(0 To w)
            vIds(w) = vData(i, 1)
            dicLogins.Add vData(i, 2), Application.CountIf(oLstObj.DataBodyRange.Columns(2), vData(i, 2))
            w = w + 1
        End If
    Next i

    'zdefiniuj tablicę wynikową
    ReDim vResult(1 To dicLogins.Count, 1 To 3)

    Set dicData = CreateObject("Scripting.Dictionary")
    i = 1
    w = oLstObj.Range.Columns.Count
    lIdsCnt = 0

    For Each Key In dicLogins.Keys

        dicData.RemoveAll
        lKeysCnt = 1
        lDataCnt = 1

        'do tymczasowego słownika (dicData) zbieraj
        'wszystkie wartości dla danego loginu
        '(z pominięciem pustych)
        Do While lKeysCnt <= dicLogins(Key)
            For lColCnt = 3 To w
                If Not IsEmpty(vData(i, lColCnt)) Then
                    dicData.Add lDataCnt, vData(i, lColCnt)
                    lDataCnt = lDataCnt + 1
                End If
            Next lColCnt

            i = i + 1
            lKeysCnt = lKeysCnt + 1
        Loop

        lIdsCnt = lIdsCnt + 1
        'wyniki przepisz do tablicy wynikowej
        vResult(lIdsCnt, 1) = vIds(lIdsCnt - 1)
        vResult(lIdsCnt, 2) = Key
        vResult(lIdsCnt, 3) = dicData.Items()    '!!! przekazywana tablica

    Next Key


    Set wksNew = Worksheets.Add(After:=Sheets(Sheets.Count))

    'przepisz wyniki z tablicy do nowego arkusza
    For i = 1 To UBound(vResult)
        wksNew.Cells(i + 1, "A").Value = vResult(i, 1)
        wksNew.Cells(i + 1, "B").Value = vResult(i, 2)

        If UBound(vResult(i, 3)) > -1 Then
            vData = vResult(i, 3)
            wksNew.Cells(i + 1, "C").Resize(, UBound(vData) + 1) = vData
        End If
    Next i

End Sub


W rozwiązaniu kumy, w zasadzie tylko teoretycznie, może się zdarzyć, że makro nie zadziała z powodu braku .NET Framework (wersja bez znaczenia, byle by jakaś była :-) ).

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 389967 Skopiuj do schowka
 
 
umiejead 
Excel Expert


Wersja: Win Office 2013
Pomógł: 720 razy
Posty: 3878
Wysłany: 21-07-2020, 05:34   

Zakładamy przynajmniej v. 3.5 (z aktualizacją) - odpowiednia do systemu: 32 / 64 (tu jest mały haczyk... ) :evil: .
.
_________________
.
Jak poprawnie opisać problem: http://www.excelforum.pl/...ika-vt59262.htm
Chcesz precyzyjną odpowiedź - zadaj precyzyjne pytanie.
ID posta: 389971 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3015 razy
Posty: 9951
Wysłany: 21-07-2020, 09:35   

Nie czuję się za bardzo gramotny w sprawach Framework-a, ale z tego co doczytałem ArrayList jest w nim od pierwszej wersji. Dlatego mówiłem że wystarczy jakikolwiek. 32/64 bit - też za bardzo nie ma znaczenia, bo stosujemy późne wiązanie. Ponownie - aby tylko był jakikolwiek. Oczywiście stosowny do wersji bitowej systemu. :-)

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 389976 Skopiuj do schowka
 
 
Bill Szysz 
Excel Expert


Wersja: Win Office 365
Pomógł: 892 razy
Posty: 3590
Wysłany: 21-07-2020, 11:29   

Oczywiście w PQ też można
Kod:
let
    Source = Excel.CurrentWorkbook(){[Name="Tabela1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,List.Transform(Table.ColumnNames(Source), each {_, type text})),
    #"Grouped Rows" = Table.Group(#"Changed Type", {"id", "name"}, {{"lst", each List.Combine(Table.ToRows(Table.RemoveColumns(_, {"id", "name"}))), type list }}),
    HowMany = Table.AddColumn(#"Grouped Rows", "Ile", each List.Count([lst])+2),
    #"Sorted Rows" = Table.Sort(HowMany,{{"Ile", Order.Descending}}),
    #"Added Custom" = Table.AddColumn(#"Sorted Rows", "Tabela", each Table.FromRows({{[id], [name]} & [lst]})),
    Combine = Table.Combine(#"Added Custom"[Tabela]),
    #"Sorted Rows1" = Table.Sort(Combine,{{"Column1", Order.Ascending}})
in
    #"Sorted Rows1
_________________
Zlecenia, konsultacje, doradztwo i szkolenia z Power Query, Power BI i Excela - Raporty, Analizy, Projekty
Pozdrawiam, były szbill62 aktualnie Bill Szysz
ID posta: 389984 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe