Transponeren verfraaien

[Pauw Gauwes]

Goede dag,

Heb het nodige doorzocht maar kom er niet uit. Wat is het probleem/verzoek.

Ik beschik over een data bestand waarvan de waarden, in rijen worden weergegeven. Via transponeren krijg ik keurig de oorspronkelijke kolomkoppen onder elkaar en lees ik in de rijen de bijbehorende waarden af.

In de 1e rij komen nu nrs voor, afhankelijk van de data komen dezelfde nrs een aantal malen voor. In de onderstaande rijen kan dan een waarde staan. Nu zou ik willen dat alle waarden die bij één nr horen in de 1e kolom van dat nr gekopieerd worden (met behoud van de opmaak) en vervolgens de overige kolommen van datzelfde nr worden verwijderd, dan houd ik keurig per nr één kolom over en wordt her veel leesbaarder.

Als er bij een nr geen waarden worden gegeven dan moet ook hier een kolom overblijven

Kan iemand me helpen op deze mooie winterdag, heb het voorbeeld bijgevoegd. Bekijk bijlage Test.xlsx


Alvast bedankt,

Groet,

Pauw

 

[Niels28]

zorg er wel voor de de schijnbaar lege cellen ook echt leeg zijn.
Vanaf regel 20 staat er iets in de schijnbaar lege cellen waardoor deze mee gekopieert worden.
Na het selecteren van deze cellen en op delete drukken werkt de macro goed.

Sub verfraaien()
    For Each cl In Range("1:1").SpecialCells(2, 1)
        If cl.Value <> cl.Offset(0, -1).Value Then
            x = 0
        Else
        x = x + 1
            c01 = c01 & cl.Column & "|"
            For Each c In Columns(cl.Column).SpecialCells(2)
                Range(c.Address).Copy Range(c.Address).Offset(0, -x)
            Next
        End If
    Next
    
    For i = UBound(Split(c01, "|")) - 1 To 1 Step -1
        c02 = Split(c01, "|")
        Columns(c02(i) * 1).Delete
    Next
End Sub

Niels

 

[Pauw Gauwes]

zorg er wel voor de de schijnbaar lege cellen ook echt leeg zijn.
Vanaf regel 20 staat er iets in de schijnbaar lege cellen waardoor deze mee gekopieert worden.
Na het selecteren van deze cellen en op delete drukken werkt de macro goed.

Sub verfraaien()
    For Each cl In Range("1:1").SpecialCells(2, 1)
        If cl.Value <> cl.Offset(0, -1).Value Then
            x = 0
        Else
        x = x + 1
            c01 = c01 & cl.Column & "|"
            For Each c In Columns(cl.Column).SpecialCells(2)
                Range(c.Address).Copy Range(c.Address).Offset(0, -x)
            Next
        End If
    Next
    
    For i = UBound(Split(c01, "|")) - 1 To 1 Step -1
        c02 = Split(c01, "|")
        Columns(c02(i) * 1).Delete
    Next
End Sub

Niels

Niels,

Bedankt voor het meedenken, het werkt al een heel eind, zit inderdaad met die schijnbaar lege cellen. Ik zie daar geen waarde instaan Ook als ik de schijnbaar lege cellen delete dan nog klopt het niet helemaal.
Bij het 1e nr 138218 blijven 2 kolommen aanwezig.

Is er een manier om te testen of cellen ook echt leeg zijn?

Groet,

Pauw

 

[Pauw Gauwes]

Niels,

Bedankt voor het meedenken, het werkt al een heel eind, zit inderdaad met die schijnbaar lege cellen. Ik zie daar geen waarde instaan Ook als ik de schijnbaar lege cellen delete dan nog klopt het niet helemaal.
Bij het 1e nr 138218 blijven 2 kolommen aanwezig.

Is er een manier om te testen of cellen ook echt leeg zijn?

Groet,

Pauw

Niels,

Denk dat schijnbaar lege cellen spaties bevatten, ik weet niet of ik daar op kan testen. Het lijkt nu beter te werken, behoudens dat het eerste nr 138218 toch 2 kolommen blijft weergeven. Is het misschien alleen de 1e range die dat doet, de overige komen keurig terug als een kolom

Groet,

Pauw

 

[Niels28]

Gelieve niet te quoten als je meteen op een bericht reageert, dit maakt het onoverzichtelijk en is tegen de forumregels.

Voor de eerste kolom weg te krijgen verander het stukje met

to 1 step -1

In

to 0 step -1

Kijk eens of dat werkt, ik doe het uit mijn hoofd heb nu geen excel ter beschikking.

Volgens mij zijn het geen spaties maar iets anders, controleren of ze leeg zijn doe ik al, kijk maar eens in help naar specialcells.
Je kunt wel proberen of het spaties zijn, zet voor de regel met copy het volgende:

if c.value <> " " then

Na de copy regel plaats

end if

Niels

 

[Pauw Gauwes]

Eerste kolom werkt nu prima

Hoi Niels,

Dat van die quote reactie wist ik niet, zal me er niet meer aan bezondigen.

Voor het probleem is het wat betreft die 1e kolom nu inderdaad opgelost. Met die spatie test lukt wat minder, ga verder uitzoeken of ik op zogenaamde lege cellen kan testen. Als ik daar niet uitkom dan ben ik al blij met deze oplossing.

Mocht je me nog wat kunnen zeggen daarover dan houd ik me aanbevolen.

Groet,

Pauw

 

[Niels28]

Volgens mij zijn die cellen niet leeg, specialcells pakt alleen cellen met iets er in.
Het is geen spatie want dat zou je kunnen zien als je in de cel staat.
Typ je de waarde zelf in de cellen of is het van een import?

Misschien dat het een alt enter is, deze is in Vba chr(13) misschien dat je daar op kunt testen.


Niels

 

[Pauw Gauwes]

Het is inderdaad een import bestand, ben dit nog nooit tegengekomen dat er waardes in cellen staan die niet te vinden zijn. Heb wel weer wat geleerd op die manier, schijnbaar moet je rekening houden met dit probleem bij een importbestand.

In ieder geval ben ik door je hulp wel een stuk verder, ga nog even puzzelen, kom ik er verder niet uit dan zet ik deze vraag wel op opgelost.

Goed weekend,

Pauw

 

[Niels28]

Ik weet niet waarom maar dit werkt, er komt nl in vba "" bij de waarde te staan en als de cel echt leeg is staat er leeg.

Sub verfraaien()
    For Each cl In Range("1:1").SpecialCells(2, 1)
        If cl.Value <> cl.Offset(0, -1).Value Then
            x = 0
        Else
        x = x + 1
            c01 = c01 & cl.Column & "|"
            For Each c In Columns(cl.Column).SpecialCells(2)
                If c.Value <> "" Then
                    Range(c.Address).Copy Range(c.Address).Offset(0, -x)
                End If
            Next
        End If
    Next
    
    For i = UBound(Split(c01, "|")) - 1 To 0 Step -1
        c02 = Split(c01, "|")
        Columns(c02(i) * 1).Delete
    Next
End Sub

Niels

 

[Pauw Gauwes]

Hoi Niels,

Heb even niet op het forum gekeken en zag pas nu dat je nog een aanvulling hebt gegeven. Inderdaad zie ik ook "" staan en anders leeg. Het originele bestand is wel groot, maar het helpt om de "probleem cellen" te vinden.

Nogmaals bedankt voor het meedenken en de terugkoppelingen

Groet,

Pauw

 

[snb]

of:

Sub M_snb()
    sn = Sheets("Blad1").Cells(1).CurrentRegion
    
    For j = 2 To UBound(sn)
      For jj = 2 To UBound(sn, 2)
         If sn(j, jj) <> "" Then sn(j, Application.Match(sn(1, jj), Application.Index(sn, 1), 0)) = sn(j, jj)
      Next
    Next
    
    For jj = 2 To UBound(sn, 2)
      If jj > Application.Match(sn(1, jj), Application.Index(sn, 1), 0) Then sn(1, jj) = ""
    Next
    
    Sheets("Blad1").Cells(1).Resize(UBound(sn), UBound(sn, 2)) = sn
    Sheets("Blad1").Rows(1).SpecialCells(4).EntireColumn.Delete
End Sub