• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

gegevens naar kolommen

Status
Niet open voor verdere reacties.
N

nicvaessen

Gebruiker
Lid geworden
6 dec 2013
Berichten
5
Waarschijnlijk is de vraag al eens gesteld en opgelost maar......
ik heb een excel sheet met in kolom 1 artikelen met in kolom 2 casnummers.
De meeste artikelen hebben een aantal (variabel) aantal casnummers.

Nu wil ik graag per artikel de casnummers in een kolom hebben.

Zie voorbeeld
 

Bijlagen

  • helpmij forum.xlsx
    9,4 KB · Weergaven: 30
Zonder het voorbeeld te bekijken, draaitabel al geprobeerd?
 
Macrootje?

Code: 
Sub hsv()
Dim sv, a, i As Long, x as long
sv = Sheets("Blad1").Cells(1).CurrentRegion
ReDim b(UBound(sv) + 1)
  With CreateObject("scripting.dictionary")
        For i = 1 To UBound(sv)
            a = .Item(sv(i, 1))
             If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 2)
                 a(UBound(a)) = a(UBound(a)) + 1
                 a(a(UBound(a)) + 1) = sv(i, 3)
                 .Item(sv(i, 1)) = a
              If x < a(UBound(a)) Then x = a(UBound(a))
        Next
    Cells(1, 10).Resize(.Count, x + 2) = Application.Index(.items, 0)
  End With
End Sub

Aardigheidje:
Code: 
Sub hsv_2()
Dim sv, a, i As Long, x As Long
sv = Sheets("Blad1").Cells(1).CurrentRegion
ReDim b(UBound(sv) + 1)
  With CreateObject("scripting.dictionary")
        For i = 1 To UBound(sv)
            a = .Item(sv(i, 1))
            c = .Item(sv(1, 1))
             If IsEmpty(a) Then a = b
                 a(0) = sv(i, 1)
                 a(1) = sv(i, 2)
                   If sv(i, 3) > 0 Then
                     a(UBound(a)) = a(UBound(a)) + 1
                     a(a(UBound(a)) + 1) = sv(i, 3)
                   End If
                 If IsEmpty(c) Then c = b
               If c(a(UBound(a)) + 1) = "" Then c(a(UBound(a)) + 1) = "Cas nr." & a(UBound(a))
                      .Item(sv(1, 1)) = c
                      .Item(sv(i, 1)) = a
              If x < a(UBound(a)) Then x = a(UBound(a))
        Next
    Cells(1, 10).Resize(.Count, x + 2) = Application.Index(.items, 0)
  End With
End Sub
 
Laatst bewerkt:
Draaitabel
 

Bijlagen

  • helpmij forum.xlsx
    13,6 KB · Weergaven: 18
draaitabel

Bedankt JV, echter de(ze) draaitabel voldoet niet aan mijn wens.
Elke Cas nummer per artikel in aparte kolom.

samenstelling Omschrijving CAS 1 CAS 2 CAS3.................
 
Nog een methode met macro.

Code: 
Sub j_v()
Set jv = Sheets(1).Cells(1).CurrentRegion
 With CreateObject("scripting.dictionary")
  For Each cell In jv.Columns(1).Offset(1).Cells
     If .Exists(cell.Value) Then
        ar = .Item(cell.Value)
        ar(1, 3) = ar(1, 3) & "@" & cell.Offset(, 2).Value
       .Item(cell.Value) = ar
     Else
       .Item(cell.Value) = cell.Resize(, 3).Value
     End If
   Next
   ar = Application.Transpose(Application.Transpose(.items))
   Cells(1, 24).Resize(.Count, 3) = ar
   Range("Z1", Cells(1, 26).End(xlDown)).TextToColumns Range("Z1"), 1, , , , , , , 1, "@"
 End With
End Sub
 
@Jv,
Gooi je methode in een array i.p.v. cel voor cel in te lezen. (sneller door uit geheugen te putten).

Code: 
ar = application.index(.items, 0)
Code: 
column(26),texttocolumns...........

Ik heb nog een tweede code geplaatst met kopteksten.
 
Laatst bewerkt:
Excel 365 optie.
 

Bijlagen

  • helpmij forum (AC).xlsx
    12,1 KB · Weergaven: 27
bedankt

ALLEMAAL hartelijk dank voor jullie input

Helaas is mijn kennis van macro's zo beperkt dat ik ze niet werkend krijg :(

Dus op zoek naar een pc/laptop met office 365 en hoera gelukt :D
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan