• 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.

horizontaal transponeren

Status
Niet open voor verdere reacties.

moensk

Gebruiker
Lid geworden
23 jun 2013
Berichten
778
ik heb in november 2019 al eens vraag gepost (deze staat al op gesloten vandaar nieuwe vraag) en toen een script gekregen
het script transponeert 1 kolom
nu had ik daar graag een aanpassing op gehad zodat 2 kolommen getransponeerd worden.
in bijlage een voorbeeld om aan te tonen

script van toen
Code:
Sub hsv()
Dim sv, i As Long, ii As Long, s0 As String, n As Long, s As Long, b
sv = Cells(1).CurrentRegion
ReDim a(UBound(sv), UBound(sv))
n = 1
For i = 2 To UBound(sv)
 a(0, 0) = sv(1, 1)
 s = 0
     If InStr(s0, "|" & sv(i, 1) & "|") = 0 Then
                s0 = s0 & "|" & sv(i, 1) & "|"
                a(n, 0) = sv(i, 1)
         For ii = i To UBound(sv)
            If sv(ii, 1) = sv(i, 1) Then
                       s = s + 1
                       a(0, s) = "opmerking " & s
               a(n, s) = sv(ii, 2)
           End If
         Next ii
       n = n + 1
    End If
    If s > b Then b = s
  Next i
 Cells(1, 5).Resize(n, b + 1) = a
End Sub
 

Bijlagen

Code:
Sub hsv()
Dim sv, i As Long, j As Long, ii As Long, s0 As String, n As Long, s As Long, b
sv = Cells(15, 1).CurrentRegion
ReDim a(UBound(sv), UBound(sv) * 2)
n = 1
For i = 2 To UBound(sv)
 a(0, 0) = sv(1, 1)
 s = 0
     If InStr(s0, "|" & sv(i, 1) & "|") = 0 Then
                s0 = s0 & "|" & sv(i, 1) & "|"
                a(n, 0) = sv(i, 1)
         For ii = i To UBound(sv)
            If sv(ii, 1) = sv(i, 1) Then
                For j = 0 To 1
                       s = s + 1
                       a(0, s) = sv(1, j + 2)
                       a(n, s) = sv(ii, j + 2)
                Next j
           End If
         Next ii
       n = n + 1
    End If
    If s > b Then b = s
  Next i
 Cells(25, 5).Resize(n, b + 1) = a
End Sub
 
HSV bedankt voor snelle reactie
ik krijg een fout 13 na ReDim a(UBound(sv), UBound(sv) * 2)
 
Er staat basis bovenaan; haal dat weg.
 
HSV,
ik had alle rijen al weg gehaald, zodat er maat 1 kopregel was doch ook dan krijg ik de melding
 
Andere optie zie Sheet1

Code:
Sub VenA()
  With Sheets("Sheet1")
    ar = .Cells(1).CurrentRegion
    Set d = CreateObject("Scripting.Dictionary")
    For j = 2 To UBound(ar)
      d(ar(j, 1)) = d(ar(j, 1)) & ar(j, 2) & "|" & ar(j, 3) & "|"
    Next j
    .Cells(1, 5).Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))
    .Columns(6).TextToColumns .Cells(1, 6), 1, , , , , , , , "|"
  End With
End Sub
 

Bijlagen

Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan