cellen onder elkaar met vba

[jeroenb93]

Hallo,

Ik zou graag namen door comma gescheiden onder elkaar getoond willen hebben. Soms heeft een cel een enkele naam, waardoor mijn vba script niet werkt.

In dit voorbeeld hieronder hebben alle cellen met namen een scheidingsteken (,) en werkt de onderstaande vba-code.



VBA-code

Sub t()
Dim i As Long, cnt As Long, spl As Variant
    With ActiveSheet
        .Range("A1:B1").Copy .Range("E1")
        For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            .Cells(i, 5) = .Cells(i, 1).Value
            spl = Split(.Cells(i, 2).Value, ",")
            cnt = UBound(spl)
            .Cells(i + 1, 1).Resize(cnt).EntireRow.Insert
            .Cells(i, 6).Resize(cnt + 1) = Application.Transpose(spl)
        Next
    End With
End Sub

Als ik het op de onderstaande manier probeer, wil dit niet omdat sommige namen geen comma bevatten. (rood gemarkeerd)



Ik stuur het excel-macro bestand mee. Sheet 1 werkt niet en sheet 2 werkt wel.

 

[VenA]

Bij maar 1 waarde is de Ubound 0 en dan werkt resize niet.

cnt = Application.Max(1, UBound(spl))

 

[jeroenb93]

Ziet er dan zo uit,

Sub t()
Dim i As Long, cnt As Long, spl As Variant
    With ActiveSheet
        .Range("A1:B1").Copy .Range("E15")
        For i = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
            .Cells(i, 5) = .Cells(i, 1).Value
            spl = Split(.Cells(i, 2).Value, ",")
            cnt = Application.Max(1, UBound(spl))
            .Cells(i + 1, 1).Resize(cnt).EntireRow.Insert
            .Cells(i, 6).Resize(cnt + 1) = Application.Transpose(spl)
        Next
    End With
End Sub

Ik zou graag willen dat deze dan niet een extra rij toevoegt.

 

[VenA]

Andere methode

Sub VenA()
  ar = Cells(1).CurrentRegion
  ReDim ar1(1, 0)
  For j = 2 To UBound(ar)
    x = Split(ar(j, 2), ",")
    For jj = 0 To UBound(x)
      If jj = 0 Then ar1(0, UBound(ar1, 2)) = ar(j, 1)
      ar1(1, UBound(ar1, 2)) = x(jj)
      ReDim Preserve ar1(1, UBound(ar1, 2) + 1)
    Next jj
  Next j
  Range("A1:B1").Copy Range("E1")
  Cells(2, 5).Resize(UBound(ar1, 2), 2) = Application.Transpose(ar1)
End Sub

 

[jeroenb93]

Thanks to VenA

Het werkt, super!


Thx

 

[jkpieterse]

Helemaal geen VBA voor nodig, zie bijlage...