Sammenlægning af rækker

Her er en starter.
Marker de celler i kolonne A som dette skal ske for.
Kør så makroen og resultatet bliver så placeret i kolonne D og E

Hvis dette virker så tager vi den derfra bagefter.

Option Base 1

Sub test()
    Dim dicX As Object
    Dim lX As Long, lNr As Long
    Dim rngC As Range, rngSelect As Range
    Dim varArray()
    Set dicX = CreateObject("Scripting.Dictionary")
    Set rngSelect = Selection

    ReDim varArray(2, rngSelect.Cells.Count)
    For Each rngC In rngSelect
        If Not dicX.Exists(CStr(rngC)) Then
            lX = lX + 1
            dicX.Add Key:=CStr(rngC), Item:=lX
            varArray(1, lX) = rngC
            varArray(2, lX) = rngC.Offset(, 1)
        Else
            lNr = dicX.Item(CStr(rngC))
            varArray(2, lNr) = varArray(2, lNr) & "," & rngC.Offset(, 1)
        End If
    Next
    ReDim Preserve varArray(2, lX)

    Range("D2").Resize(lX, 2) = Application.Transpose(varArray)
End Sub

forslag - Indsæt koden i arket med data:

Dim antalRæk, optælTab(), antalProdukter

Sub Optælling()
Rem Housekeeping
    antalRæk = findAntalRækker
    ReDim optælTab(antalRæk, 2)
    nulstilTabel
   
    optælRækker
   
    visOptælling
End Sub
Private Function findAntalRækker()
    findAntalRækker = Cells(Rows.Count, 1) _
      .End(xlUp).Offset(1, 0).Row - 1
End Function
Private Sub nulstilTabel()
    For ix = 0 To antalRæk - 1
        optælTab(ix, 0) = ""                        'produkt
        optælTab(ix, 1) = ""                        'lande
    Next ix
End Sub
Private Sub optælRækker()
Dim sælger, oms, antal
    antalProdukter = 0
   
    For ræk = 1 To antalRæk
        produkt = Cells(ræk, 1)
        land = Cells(ræk, 2)
       
        optælItabel produkt, land
    Next ræk
End Sub
Private Sub optælItabel(produkt, land)
    For ix = 0 To antalRæk - 1
        If optælTab(ix, 0) = produkt Then
            optælTab(ix, 1) = optælTab(ix, 1) + land + ", "
            Exit Sub
        Else
            If optælTab(ix, 0) = "" Then
                optælTab(ix, 0) = produkt
                optælTab(ix, 1) = land + ", "
                antalProdukter = antalProdukter + 1
                Exit Sub
            End If
        End If
    Next ix
End Sub
Private Sub visOptælling()
Dim rRæk
    rRæk = antalRæk + 2
   
    For produkt = 0 To antalProdukter - 1
        Cells(rRæk, 1) = optælTab(produkt, 0)
        Cells(rRæk, 2) = Left(optælTab(produkt, 1), Len(optælTab(produkt, 1)) - 2)
        rRæk = rRæk + 1
    Next produkt
End Sub

Her er endnu et forslag. Gør sikkert det samme som ovenstående koder, har ikke testet. Men nu var jeg igang med koden.


Sub test1()

Dim I, J, X, Y, rk
Dim frugt(), lande(), tekst()

rk = Range("A65536").End(xlUp).Row
data = Range("A1:B" & rk)
Range("D1:E" & rk).ClearContents
ReDim frugt(3)

For I = 1 To rk
    antal = WorksheetFunction.CountIf( _
    Range("A" & I & ":A" & rk), data(I, 1))
    If antal = 1 Then
        frugt(X) = data(I, 1)
        X = X + 1
    End If
Next I

ReDim Preserve frugt(X - 1)
ReDim tekst(rk, 1)
For I = 1 To X
ReDim lande(rk)
        For J = 1 To rk
            If data(J, 1) = frugt(I - 1) Then
                lande(Y) = data(J, 2)
                Y = Y + 1
            End If
        Next J
ReDim Preserve lande(Y - 1)
tekst(I - 1, 0) = frugt(I - 1)
tekst(I - 1, 1) = Join(lande, ";")
Y = 0
Next I

Range("D1").Resize(X, 2) = tekst

End Sub

Og så lige den rigtige :-)


Sub test1()

Dim I, J, X, Y, rk
Dim frugt(), lande(), tekst()

rk = Range("A65536").End(xlUp).Row
data = Range("A1:B" & rk)
Range("D1:E" & rk).ClearContents
ReDim frugt(rk)

For I = 1 To rk
    antal = WorksheetFunction.CountIf( _
    Range("A" & I & ":A" & rk), data(I, 1))
    If antal = 1 Then
        frugt(X) = data(I, 1)
        X = X + 1
    End If
Next I

ReDim Preserve frugt(X - 1)
ReDim tekst(rk, 1)
For I = 1 To X
ReDim lande(rk)
        For J = 1 To rk
            If data(J, 1) = frugt(I - 1) Then
                lande(Y) = data(J, 2)
                Y = Y + 1
            End If
        Next J
ReDim Preserve lande(Y - 1)
tekst(I - 1, 0) = frugt(I - 1)
tekst(I - 1, 1) = Join(lande, ";")
Y = 0
Next I

Range("D1").Resize(X, 2) = tekst

End Sub

her er min første, lavet lidt om, så man ikke skal markere og kolonne A & B bliver overskrevet..

Option Base 1

Sub test1()
    Dim dicX As Object
    Dim lX As Long, lNr As Long, lR As Long
    Dim varC As Variant
    Dim varResults()
    Dim varAllCells As Variant

    'initialiser et dictionary til kolonne A
    Set dicX = CreateObject("Scripting.Dictionary")
    'Find sidste række i kolonne A
    lR = Range("A65536").End(xlUp).Row
    'indlæs alle celler i et array
    varAllCells = Range("A2:B" & lR)
    'dimensioner resultatmatricen
    ReDim varResults(2, UBound(varAllCells, 1))
    'gennemgå kolonne A i varAllCells
    For y = 1 To UBound(varAllCells, 1)
        'omdan værdien til streng
        varC = CStr(varAllCells(y, 1))
        'check om den findes i forvejen
        If Not dicX.Exists(varC) Then
            'findes den ikke så indsæt den i dictionary
            lX = lX + 1
            dicX.Add Key:=varC, Item:=lX
            'indsæt den også i resultatmatricen
            varResults(1, lX) = varC
            'indsæt også værdien fra kolonne B
            varResults(2, lX) = varAllCells(y, 2)
        Else
            'Findes den i forvejen så find dens nummer i resultatmatricen
            lNr = dicX.Item(varC)
            'læg værdien fra kolonne B til den værdi der var i forvejen
            varResults(2, lNr) = varResults(2, lNr) & "," & varAllCells(y, 2)
        End If
    Next
    'redimensioner resultatmatricen til aktuelle data
    ReDim Preserve varResults(2, lX)
    'slet de gamle data
    Range("A2:B" & lR).ClearContents
    'indsæt de nye data vhor de gamle startede
    Range("A2").Resize(lX, 2) = Application.Transpose(varResults)
End Sub

Hej BAK og mrjh

Jeg har lige prøvet begge Jeres løsningsforslag og de virker begge to - glimrende.

Så jeg har tænkt at give Jer hver 150.

Ups, jeg er ikke lige vant til at bruge eksperten.

BAK, kan du ikke lige svare på denne, hvorefter jeg kan acceptere?

mrjh, jeg opretter "Sammenlægning af rækker - 2", kan du ikke lige svare på den?

Ellers takker jeg mange gange.

Ups, ups

mrjh, jeg halv sover. du skal lige svare på denne her.

Se evt. andet spørgsmål fra min side http://www.eksperten.dk/spm/819065

Godt du kunne bruge det. Her er et svar. Afvent svar fra Bak, og så deler vi i porten.