http://www.eksperten.dk/spm/942804

..er stadig med..

Et eksempel med de relevante kolonner (før) og efter transponering med de nu ønskede tilføjelser - ville være nyttigt.

Kan evt. sendes - @-adresse under min profil.

Du får et eksempel :-)

Rem Version 3
Rem =========
Const basisArkNavn = "Sheet1"
Dim basisArk As Worksheet
Dim antalRæk As Long, antalKol As Long

Const FCSNavn = "Feature Code String"
Public Sub transponerOgFordel_2()
Dim id, fcs As String, fcq As String
    antalKol = ActiveCell.SpecialCells(xlLastCell).Column
    antalRæk = ActiveCell.SpecialCells(xlLastCell).Row
    Set basisArk = ActiveWorkbook.Sheets(basisArkNavn)
   
    Application.ScreenUpdating = False
   
    For ræk = 2 To antalRæk
        basisArk.Select
        id = Range("A" & ræk)
        Union(Range("1:1"), Range(ræk & ":" & ræk)).Select
       
        Selection.Copy
        ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = id
        ActiveSheet.Range("A1").Select
        Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

        Application.CutCopyMode = False
        ActiveSheet.Columns.AutoFit
       
        If ActiveSheet.Range("A" & 112) = FCSNavn Then
            fcs = ActiveSheet.Range("B" & 112)
            fcq = ActiveSheet.Range("B" & 113)
           
            If fcs <> "" Then
                indsætFCS antalKol + 1, fcs, fcq
            End If
        Else
            MsgBox FCSNavn & "-kolonne ikke identificeret"
            Stop
        End If
        fcs = ""
    Next ræk
   
    Application.ScreenUpdating = True
End Sub
Private Sub indsætFCS(ræk, fcs As String, fcq As String)
Dim fcsSplit As Variant, f As Long, deScript As String
Dim fcqSplit As Variant
    If Right(fcs, 1) <> "_" Then
        fcs = fcs + "_"
    End If
       
    If Right(fcq, 1) <> "_" Then
        fcq = fcq + "_"
    End If
   
    fcsSplit = Split(fcs, "_")
    fcqSplit = Split(fcq, "_")
   
    For f = 0 To UBound(fcsSplit)
        deScript = hentDescription(fcsSplit(f))
        ActiveSheet.Range("A" & ræk) = deScript
        ActiveSheet.Range("B" & ræk) = fcqSplit(f)
       
        ræk = ræk + 1
    Next f
End Sub
Private Function hentDescription(søgeOrd)
Dim dcsRæk As Long
    With ActiveWorkbook.Sheets("Feature").Range("A1:A65000")
        Set c = .Find(søgeOrd, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            dcsRæk = c.Row
            hentDescription = .Cells(dcsRæk, 3)
        Else
            hentDescription = "??-<" & søgeOrd & ">-??"
        End If
    End With
End Function

Endnu engang tak