VBA speciel transponering

Jeg kan ikke få dit link til at virke ?
http://gupl.dk/685589/
mvh
finb

Hmm, det fungerer fint for mig.

Baracuda antivirus stopper vist gupl,
kan du evt vise de rå tal som txt ?
finb

Data er struktureret som vist her (kolonnerne A-Z)

ParentA 1 2 3 4
ParentB 5 6
ParentC 7 8 9 10 11 12
ParentD
ParentE 13 14

Som vist er der parents uden værdier (child).

På et andet faneblad ønsker jeg data vist i to kolonner:

ParentA 1
ParentA 2
ParentA 3
ParentA 4
ParentB 5
ParentB 6
ParentC 7
ParentC 8
ParentC 9
ParentC 10
ParentC 11
ParentC 12
ParentE 13
ParentE 14

Som det fremgår, ønsker jeg ikke, at parents uden childs vises.

Har fået løsning på anden vis.

Til info. Løsningsforslag modtaget fra Mr. Excel forum:

**********************

Option Explicit
Sub ReorgData()
' hiker95, 10/06/2012
Dim w1 As Worksheet, wR As Worksheet
Dim i As Variant, o As Variant
Dim r As Long, lr As Long, c As Long, lc As Long, n As Long, nr As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("As-is")
lr = w1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
lc = w1.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
i = w1.Range(w1.Cells(1, 1), w1.Cells(lr, lc))
n = Application.CountA(w1.Range(w1.Cells(1, 2), w1.Cells(lr, lc)))
ReDim o(1 To n, 1 To 2)
nr = 0
For r = 1 To UBound(i, 1)
  For c = 2 To UBound(i, 2)
    If i(r, c) <> "" Then
      nr = nr + 1
      o(nr, 1) = i(r, 1)
      o(nr, 2) = i(r, c)
    End If
  Next c
Next r
If Not Evaluate("ISREF(To-be!A1)") Then Worksheets.Add(After:=w1).Name = "To-be"
Set wR = Worksheets("To-be")
wR.UsedRange.Clear
wR.Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
wR.Cells.EntireColumn.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub