slim ontdubbelen en presenteren

[Manke]

Hoi,
Zou iemand mij willen helpen aan een VB script die in mijn Excel werkblad slim ontdubbeld en presenteert?
Ik heb een voorbeeld bestand toegevoegd.
Hoop dat iemand bereid is mij hierin te helpen.
Alvast bedankt
Manke

 

[Timshel]

Sub tsh()
    Dim Br
    Dim i As Long, j As Long
    Dim y As Long, p As Long
    Dim It, Ix, Ih
    
    Br = Cells(3, 1).CurrentRegion
    y = 4 + Evaluate("sumproduct(1/countif(D4:D" & 2 + UBound(Br) & ",D4:D" & 2 + UBound(Br) & "))")
    ReDim Ix(y)
    Ih = Ix
    With CreateObject("Scripting.Dictionary")
        .Item(0) = Ih
        Ih(0) = Br(1, 1)
        Ih(1) = Br(1, 2)
        Ih(2) = Br(1, 3)
        For i = 2 To UBound(Br)
            It = .Item(Br(i, 1))
            If IsEmpty(It) Then
                It = Ix
                It(0) = Br(i, 1)
                It(1) = Br(i, 2)
                It(2) = Br(i, 3)
            End If
            If IsError(Application.Match(Br(i, 4), Ih, 0)) Then
                Ih(3 + p) = Br(i, 4)
                p = p + 1
            End If
            It(Application.Match(Br(i, 4), Ih, 0) - 1) = Br(i, 5)
            .Item(Br(i, 1)) = It
        Next
        .Item(0) = Ih
        Range("A20").Resize(.Count, y) = Application.Index(.Items, 0)
    End With
End Sub

 

[Manke]

Hey Timshel,
Dank voor je reactie.
Ik kan 'm nu even niet proberen, maar morgen ga ik er voor.
Alvast dank voor alle moeite en je leest morgen mn bevindingen.

Groet
Manke

 

[pixcel]

Ik had verwacht dat dit voor Power Query een lastige opgave zou zijn maar hij bleek verbluffend simpel.

 

[snb]

Sub M_snb()
  With Cells(3, 1).CurrentRegion
    sn = .Resize(, .Columns.Count + 3)
  End With
  
  For j = 2 To UBound(sn)
     sn(j, InStr("     DMB", Left(sn(j, 4), 1))) = sn(j, 5)
     If j > 2 And sn(j, 1) = sn(j - 1, 1) Then
        If sn(j - 1, 6) <> "" Then sn(j, 6) = sn(j - 1, 6)
        If sn(j - 1, 7) <> "" Then sn(j, 7) = sn(j - 1, 7)
        If sn(j - 1, 8) <> "" Then sn(j, 8) = sn(j - 1, 8)
     ElseIf j > 2 Then
        c00 = c00 & "_" & j - 1
    End If
  Next
  c00 = c00 & "_" & j - 1
  
  st = Application.Transpose(Split(Mid(c00, 2), "_"))
  
  Cells(20, 1).Resize(UBound(st), 6) = Application.Index(sn, st, Array(1, 2, 3, 6, 7, 8))
End Sub

 

[Manke]

Pfewwww

Allereerst heel hartelijk dank voor het meedenken!!
Zelf dacht ik dat ik al redelijk iets van Excel wist, maar ik kruip maar snel weer onder mijn steen.
Heb de VB scripts gebruikt en ze werken!!
Toen dacht ik "nu nog even het script omzetten naar mijn werkelijke situatie"...
Oeps... heb veel met de scripts zitten stoeien, heb er ook op gegoogled, maar jullie oplossingen zijn toch een treetje te hoog voor mij. Ik krijg er geen vat op.
Niet dat ik voor de gemakkelijkste weg zal gaan, want ik moet en zal het script gaan begrijpen.
Toch moet ik verder en er zit wat druk achter.

Wat ik nu heb gedaan is de werkelijke Excel layout bijgevoegd waar mee ik aan de slag moet en moet ontdubbelen.
Ik heb nu slechts een aantal rijen weergegeven , maar die lijst kan wel uit 2000 rijen bestaan.
Het probleem blijft hetzelfde.
Mijn vraag zouden jullie mij nog een keer willen helpen met het script, maar nu aangepast op bijgevoegd Excel blad?
Begrijp me goed, ik wil dit onder de knie krijgen, maar er zit nu wat druk achter.
Hoop dat jullie me uit de brand willen helpen.
Alvast bedankt.

PS De nieuwe ontdubbelde tabel met nieuwe kolom per connectieomschrijving mag ook op Blad2 weergegeven worden hoor.

 

[Timshel]

Ik kom uit op onderstaande code.
Voeg een leeg werkblad "Blad2" in en voer de code uit.
Mijn oorspronkelijke code crasht op lege cellen in kolom J. Ik heb daar een weinig elegante oplossing voor: de lege cellen worden gevuld met de tekst "Geen relatie". Die tekst komt ook terug als aparte kolom in de uitvoer.

Sub tsh()
    Dim Br
    Dim i As Long, j As Long
    Dim y As Long, p As Long
    Dim It, Ix, Ih
    
    Br = Sheets("Blad1").Cells(1, 1).CurrentRegion
    For i = 2 To UBound(Br)
        If Br(i, 10) = "" Then
            Br(i, 10) = "Geen relatie"
            Sheets("Blad1").Cells(i, 10) = "Geen relatie"
        End If
    Next
    y = 9 + Evaluate("sumproduct(1/countif(J2:J" & UBound(Br) & ",J2:J" & UBound(Br) & "))")
    ReDim Ix(y)
    Ih = Ix
    With CreateObject("Scripting.Dictionary")
        .Item(0) = Ih
        For j = 0 To 8
            Ih(j) = Br(1, j + 1)
        Next
        For i = 2 To UBound(Br)
            It = .Item(Br(i, 1))
            If IsEmpty(It) Then
                It = Ix
                For j = 0 To 8
                    It(j) = Br(i, j + 1)
                Next
            End If
            If IsError(Application.Match(Br(i, 10), Ih, 0)) Then
                Ih(9 + p) = Br(i, 10)
                p = p + 1
            End If
            It(Application.Match(Br(i, 10), Ih, 0) - 1) = Br(i, 12)
            .Item(Br(i, 1)) = It
        Next
        .Item(0) = Ih
        Sheets("Blad2").Cells(1, 1).Resize(.Count, y) = Application.Index(.Items, 0)
    End With
End Sub

 

[Manke]

Tx

Hey Timshel,

Dank voor je snelle reactie en t werk wat je verricht hebt!!
Ik heb het net even snel geprobeerd en voor zover ik het zo snel kan bekijken werkt het perfect!!
Straks nog even verder mee stoeien, maar tot zover: Enorm bedankt!!! :thumb:
Wanneer alles 100% blijkt te werken zal ik mijn vraag op opgelost zetten.

Hartelijke groet
Marco

 

[snb]

Ik vind het leuker als je zelf wat gaat stoeien met de aangereikte suggesties.
97% van je vraag is opgelost. Die resterende 3% zouden je eer te na moeten zijn.

 

[Manke]

hoi SNB

Ik begrijp je hoor.
Maar zoals gezegd, ik dacht dat ik redelijk handig was met Excel. Heel veel los ik op zonder gebruik van VB. En dat gaat me best goed af. Een enkele keer grijp ik naar naar VB, maar heeeeeeeeeeel basic begrijp ik nu door jullie aangedragen oplossingen.
Laat ik het zo zeggen; jullie inbreng heeft mij maar "meer" doen smaken. En dat meen ik!! Maar besef ook dat ik nog een lange weg te gaan heb. Een en ander moest klaar, vandaar mijn hernieuwde oproep. En geloof me, ik vond het ook wat zwak van me, maar ben daar nu even over heen gestapt om tot een doel te komen en ben heel erg blij dat ik middels dit forum geholpen ben.
Maar had ik meer tijd gehad, dan had ik letter voor letter nageplozen. Dat had ik nu niet, maar dat wil niet zeggen dat ik het ook niet zou willen begrijpen. Nogmaals jullie inbreng was een stimulans voor mij om me meer te verdiepen in VB, want wat is Excel toch een geweldig programma, en wat weet ik toch nog weinig.
Bedankt voor je reactie SNB

 

[pixcel]

Nou vooruit, nog één keer met Power Query.

let
    Bron = Excel.CurrentWorkbook(){[Name="Tabel1"]}[Content],
    #"Type gewijzigd" = Table.TransformColumnTypes(Bron,{{"Relatie.Dossiernummer", Int64.Type}, {"Relatie.Samengestelde naam", type text}, {"Relatie.Postadres", type text}, {"Relatie.Huisnummer postadres", Int64.Type}, {"Relatie.Toevoeging huisnummer postadres", type text}, {"Relatie.Postcode postadres", type text}, {"Relatie.Plaats postadres", type text}, {"Relatie.Tekenend accountant", Int64.Type}, {"Relatie.Relatiebeheerder", Int64.Type}, {"Connectie.Connectieomschrijving", type text}, {"Gekoppelde relatie.Dossiernummer", Int64.Type}, {"Gekoppelde relatie.Samengestelde naam", type text}, {"Gekoppelde relatie.Postadres", type text}, {"Gekoppelde relatie.Huisnummer postadres", Int64.Type}, {"Gekoppelde relatie.Toevoeging huisnummer postadres", type text}, {"Gekoppelde relatie.Postcode postadres", type text}, {"Gekoppelde relatie.Plaats postadres", type text}}),
    #"Gefilterde rijen" = Table.SelectRows(#"Type gewijzigd", each [Connectie.Connectieomschrijving] <> null),
    #"Gedraaide kolom" = Table.Pivot(#"Gefilterde rijen", List.Distinct(#"Gefilterde rijen"[Connectie.Connectieomschrijving]), "Connectie.Connectieomschrijving", "Gekoppelde relatie.Samengestelde naam")
in
    #"Gedraaide kolom"