Helpmij.nl
Helpmij.nl
Helpmij.nl
Steun Helpmij.nl! Klik hier     Computerprobleem? Klik hier!

Quote

Weergeven resultaten 1 tot 8 van 8

Onderwerp: Excel 1 rij transponeren en dubbele regels verwijderen

  1. #1
    Giga Senior
    Verenigingslid
    globe's avatar
    Geregistreerd
    18 maart 2001
    Locatie
    Nunspeet
    Afstand tot server
    ±25 km
    Vraag is opgelost

    Excel 1 rij transponeren en dubbele regels verwijderen

    Goedendag,

    Ik heb een Excel waar data onder elkaar staan die ik wil inkorten.

    In bijgaand voorbeeld moet er naar artikelnummer (kolom 3) en maat (kolom 5) gekeken worden.

    Deze maten, moeten achter elkaar geplaatst worden en door bv. een komma gescheiden worden. Of liggend streepje oid.

    Vervolgens moet de lijst worden ingekort zodat er geen dubbele waarden achter blijven.

    Ooit heb ik onderstaand script gebruikt om een soortgelijk resultaat te krijgen op basis van een andere file, zie topic: https://www.helpmij.nl/forum/showthr...inhoud-kolom-A

    maar ik krijg het niet voor elkaar deze werkend te krijgen.

    Wie wil me even op weg helpen?

    alvast bedankt!

    Guido

    Code:
    Sub ff()
    Dim Output() As Variant
        
        Tabel = Sheets(1).Cells(1).CurrentRegion
        x = 0
        For i = 2 To UBound(Tabel, 1)
            If Tabel(i, 1) <> Tabel(i - 1, 1) Then
                x = x + 1
                ReDim Preserve Output(1 To x)
                For ii = 1 To 3
                    Output(x) = Output(x) & Tabel(i, ii) & ","
                Next ii
            Else
                Output(x) = Output(x) & Tabel(i, 3) & ","
            End If
        Next i
        
        With Sheets.Add(after:=Sheets(Sheets.Count))
            .Cells(1).Resize(UBound(Output, 1), 1) = Application.Transpose(Output)
            .Columns(1).TextToColumns Comma:=True
        End With
        
    End Sub
    Bijgevoegde bestanden Bijgevoegde bestanden
    ...with all the money in the world, you cannot buy respect...

  2. #2
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    Code:
    Sub VenA()
      ar = Sheets("Blad1").Cells(1).CurrentRegion
      Set d = CreateObject("Scripting.Dictionary")
      For j = 1 To UBound(ar)
        If d.exists(ar(j, 3)) Then d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), d(ar(j, 3))(4) & ", " & ar(j, 5)) Else d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5))
       Next j
       Cells(1, 10).Resize(d.Count, 5) = Application.Index(d.items, 0, 0)
    End Sub
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  3. #3
    Giga Senior
    Verenigingslid
    globe's avatar
    Geregistreerd
    18 maart 2001
    Locatie
    Nunspeet
    Afstand tot server
    ±25 km
    top! Dat gaat lekker.

    Achter mijn data staan nog meer kolommen, hoe kan ik deze mee kopiëren? Deze vervallen nu namelijk.

    En kan ik de gehele output ook naar een nieuw blad kopiëren?
    ...with all the money in the world, you cannot buy respect...

  4. #4
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    1. Door meer kolommen aan de array toe te voegen.
    Code:
    Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5),ar(j, 6),etc)
    2. Door naar het juiste blad te verwijzen.
    Code:
    sheets("Blad2").Cells(1, 10).Resize(d.Count, 5) = Application.Index(d.items, 0, 0)
    Laatst aangepast door VenA : 11 juli 2019 om 12:39
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  5. #5
    Giga Senior
    Verenigingslid
    globe's avatar
    Geregistreerd
    18 maart 2001
    Locatie
    Nunspeet
    Afstand tot server
    ±25 km
    Helaas, ik krijg een foutmelding.

    heb dit er van gebakken:

    Code:
    Sub VenA()
      ar = Sheets("Blad1").Cells(1).CurrentRegion
      Set d = CreateObject("Scripting.Dictionary")
      For j = 1 To UBound(ar)
        If d.exists(ar(j, 3)) Then d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), d(ar(j, 3))(4) & ", " & ar(j, 5), ar(j, 6), ar(j, 7), ar(j, 8)) Else d(ar(j, 3)) = Array(ar(j, 1), ar(j, 2), ar(j, 3), ar(j, 4), ar(j, 5), ar(j, 6), ar(j, 7), ar(j, 8))
       Next j
       Sheets("Blad2").Cells(1, 1).Resize(d.Count, 5) = Application.Index(d.items, 0, 0)
    End Sub
    ...with all the money in the world, you cannot buy respect...

  6. #6
    Giga Honourable Senior Member
    Geregistreerd
    2 maart 2013
    Dan moet je maar even debuggen. Code wordt gemaakt obv voorbeeldbestandjes. Als dit niet strookt met de werkelijkheid dan moet je het zelf oplossen.
    Je kan een paard naar het water leiden, maar je kan het niet dwingen te drinken.

  7. #7
    Giga Honourable Senior Member
    Geregistreerd
    18 juli 2008
    @globe,

    Je hebt er waarschijnlijk lege kolommen tussen.
    ____________
    Met vriendelijke groet,
    Harry

    Lag nooit om de keuzes van dien vraauw, bist ter zulf aine van....
    (Grunnegs-Gronings)

  8. #8
    Giga Senior
    Verenigingslid
    globe's avatar
    Geregistreerd
    18 maart 2001
    Locatie
    Nunspeet
    Afstand tot server
    ±25 km
    Bedankt voor de hulp, lege cellen deden inderdaad het script de das om. 255 karakters ga ik sowieso nooit redden.

    Ik ga er weer mee verder, bedankt allemaal tot zover.

    Guido
    ...with all the money in the world, you cannot buy respect...

Berichtenregels

  • U mag geen nieuwe vragen starten.
  • U mag niet reageren op berichten.
  • U mag geen bijlagen versturen.
  • U mag uw berichten niet bewerken.
  •  
Helpmij.nl
Helpmij.nl

Helpmij.nl en business

Partners
Sponsoren