Samle tekst fra flere linie i et ark, til et felt i andet ark

Forestiller du dig en makro?

Er der en større mangde, der skal behandles og hvordan er disse evt. organiseret?

Er ark2 klargjort på forhånd?

Det kunne være en macro eller noget VBA, er ikke nogen haj til Excel, så ved ikke helt hvad mulighederne er.

Ja, det er ca. 1800 varenumre det drejer sig om, med 0-20 liniers tekst til hver.

Ark 2 er klargjort, der er oprettet en linje pr. varenr. og varenavn osv. er flyttet over, så der mangler kun varebeskrivelsen.

Hvis muligt er du velkommen til at sende filen eller repræsentivt uddrag - så vil jeg godt se på det..

@-adr. under profil.

Jeg har sendt en fil med et lille eksempel på hvad det er jeg mener.

Dim ark1 As Worksheet

Dim varenr As Long, antalRækker, række As String, beskrivelse As String, r As Long, rækArk1 As Long
Public Sub samlingAfBeskrivelse()
    Application.ScreenUpdating = False
   
    antalRækker = ActiveCell.SpecialCells(xlLastCell).Row
    Set ark1 = ActiveWorkbook.Sheets(1)
   
    For ræk = 2 To antalRækker
        række = ræk
        If Range("A" & række) <> "" Then
            varenr = Range("A" & række)
            rækArk1 = findVareNr(varenr)
           
            If rækArk1 > 0 Then
                beskrivelse = ""
                For r = rækArk1 To 65000
                    While ark1.Range("C" & CStr(r)) = varenr
                        beskrivelse = beskrivelse & ark1.Range("F" & CStr(r)) & vbLf
                        r = r + 1
                    Wend
                    Exit For
                Next r
                   
Rem Sidste linieskift fjernes
                If beskrivelse <> "" Then
                    beskrivelse = Left(beskrivelse, Len(beskrivelse) - 1)
                    Range("D" & række) = beskrivelse
                End If
            End If
        End If
    Next ræk
   
    ActiveSheet.Columns.AutoFit
    ActiveSheet.Rows.AutoFit
   
    Application.ScreenUpdating = True
    MsgBox ("Samling udført")
End Sub
Private Function findVareNr(varenr)
    With ark1.Range("C:C")
        Set c = .Find(varenr, LookIn:=xlValues, LookAt:=xlWhole)
        If Not c Is Nothing Then
            findVareNr = c.Row
        Else
            findVareNr = 0
        End If
    End With
    Exit Function
End Function

Super, tusind tak for hjælpen.