Macro med 2 celler samlet i en i 2 rækker

Rem Kode til opbygning af det ønskede for en række.
Rem Integreres med bestående kode.

Sub test()
Const Serieræk = 107                    'Test
Dim LabelsRæk As Integer
Dim serieData As String, gruppeData As String, labelsData As String
Dim startPosSerie As Integer
    LabelsRæk = 1
   
    With ActiveWorkbook.Sheets("Serie")
        serieData = .Range("I" & Serieræk)
        gruppeData = .Range("G" & Serieræk)
       
        labelsData = serieData & vbCrLf & gruppeData
    End With

    ActiveSheet.Range("A" & LabelsRæk) = labelsData
    startPosSerie = InStr(labelsData, gruppeData)
    If startPosSerie > 0 Then
        formaterSerie startPosSerie, Len(serieData)
    End If
   
    ActiveSheet.Columns.AutoFit
End Sub
Private Sub formaterSerie(startPos, lgdSerie)
    With ActiveCell.Characters(Start:=startPos, Length:=lgdSerie).Font
        .Name = "Arial Narrow"          '<------- Eksempel
        .Size = 12                      '<------- - " -
    End With
End Sub

Det virker men jeg er da godt nok lost med at få dem bygget sammen.

Public Sub Labels()
    Dim Data As Variant, i As Integer, K As Integer, Col As Integer, Rw As Integer
    RK = Worksheets("Serie").Range("I1").End(xlDown).Row
    Data = Worksheets("Serie").Range("H1:I1" & RK)
    Col = 0
    Rw = 1
   

    For i = 2 To UBound(Data, 1)
        For K = 1 To Data(i, 1)
            Col = Col + 1
            If Col = 6 Then
                Col = 1
                Rw = Rw + 1
            End If

            Worksheets("Labels").Cells(Rw, Col) = Data(i, 2)    'ret Ark2 til dit labelsark

Vender tilbage..

mange tak :). Jeg har problemer med at forstå selv den jeg bruger nu, prøver at bytte rundt på det hele for at se hvad er hvad. Men det giver ikke meget mening for mig

Version 2

Dim Data As Variant, i As Integer, K As Integer, Col As Integer, Rw As Integer
Public Sub MakeLabels()
Dim serieData As String, typeData As String, startPos As Integer, labelsData As String
    RK = Worksheets("Serie").Range("I1").End(xlDown).Row
    Data = Worksheets("Serie").Range("H1:I1" & RK)
    Col = 0
    Rw = 1
   
    For i = 2 To UBound(Data, 1)
   
        For K = 1 To Data(i, 1)
            Col = Col + 1
            If Col = 6 Then
                Col = 1
                Rw = Rw + 1
            End If
           
            serieData = Data(i, 2)
           
            With ActiveWorkbook.Sheets("Serie")
                typeData = .Range("G" & Rw + 1)
                labelsData = serieData & vbCrLf & typeData
                startPos = InStr(labelsData, typeData)
            End With
           
            Worksheets("Labels").Cells(Rw, Col) = Data(i, 2) & vbCrLf & Sheets("Serie").Range("G" & Rw + 1)
           
            formaterLabel startPos, Len(typeData)
        Next K
        Sheets("Serie").Activate
    Next i
   
    Worksheets("Labels").Columns.AutoFit
End Sub
Private Sub formaterLabel(startPos, lgdSerie)

    If startPos > 0 Then
        With Sheets("Labels").Cells(Rw, Col).Characters(Start:=startPos, Length:=lgdSerie).Font
            .Name = "Arial Narrow"          '<------- Eksempel
            .Size = 12                      '<------- - " -
        End With
    End If
End Sub

Fedt det virker. Mange tak vil lige bruge noget tid på at finde ud af hvordan det helt virker. Mange mange tak

Ellers kan du blot spørge.
Fint det virker og selv tak