Data fra to rækker samlet i en

Hej

Hvad skal der ske hvis der er flere end 1 genganger?  Skal der være flere kolonner hvis der er 2, 3 eller flere gengangere.

Jeg har lavet en lille makro, som måske kan bruges. Hvis du har dine data liggende i kolonnerne A:C vil makroen skrive de ønskede lister i området J1:T1000.

Sub Samling()
Dim LastRow, OpR, NyR, NyC, ROpslag As Integer
LastRow = ActiveSheet.UsedRange.Rows.Count
Range("J1:T1000").ClearContents
NyR = 1
For x = 1 To LastRow
If Application.WorksheetFunction.CountIf(Range("J1:J10000"), Cells(x, 1)) = 0 Then
Range(Cells(x, 1), Cells(x, 3)).Copy
Range("J" & NyR).PasteSpecial
NyR = NyR + 1
Else
If Application.WorksheetFunction.CountIf(Range("K1:K10000"), Cells(x, 2)) = 0 Then
Range(Cells(x, 1), Cells(x, 3)).Copy
Range("J" & NyR).PasteSpecial
NyR = NyR + 1
Else
ROpslag = Application.Match(Cells(x, 1).Value & " - " & Cells(x, 2).Value, Range("I1:I10000"), 0)
NyC = Application.CountA(Range(Cells(ROpslag, 10), Cells(ROpslag, 20)))
For y = 3 To 6
If Application.WorksheetFunction.CountIf(Range(Cells(ROpslag, 12), Cells(ROpslag, 20)), Cells(x, 3)) = 0 Then
Cells(ROpslag, 10 + NyC) = Cells(x, y)
NyC = NyC + 1
End If
Next
End If
End If
Next
End Sub

Dine data forventes at starte i række 2 (test på en kopi)

Sub udRader()
rk = Cells(65536, "A").End(xlUp).Row

For Each c In Range("A2:A" & rk)
If c <> "" Then
  For Each d In Range("A" & c.Row + 1 & ":A" & rk)
    If d = c And c.Offset(0, 2) <> d.Offset(0, 2) Then
    x = x & "-" & d.Offset(0, 2)
      Range("A" & d.Row & ":C" & d.Row) = ""
    c.Offset(0, 3) = x
    End If
  Next
End If
x = ""
Next

Range("A2:A" & rk).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp

End Sub

Der var lige en ting jeg glemte. I celle I1 og nedefter skal du skrive formelen:

=J1&" - "&K1

@Jens48 - det ser ud til at virke for rækker hvor der er data i både A og B, men hvis B er blank lægger den ikke rækkerne sammen.
Eksempel
Kolonne A - B - C - (D)
10267 - 917 - ABCD
10267 - 917 - XYZ
Bliver rigtigt nok til
10267 - 917 - ABCD - XYZ

Men hvis rækkerne i steder er
10267 - " " - ABCD
10267 - " " - XYZ
Returnere den
10267 - " " - ABCD
10267 - " " - XYZ

Har du en løsning så også de rækker med blank kolonne B men samme værdi i kolonne A bliver sammenlagt?

@excelent får følgende fejl:
Compile error:
Syntax error

Prøv med:

Sub Samling()
Dim LastRow, OpR, NyR, NyC, ROpslag As Integer
LastRow = ActiveSheet.UsedRange.Rows.Count
Range("J1:T1000").ClearContents
NyR = 1
For x = 1 To LastRow
If Application.WorksheetFunction.CountIf(Range("J1:J10000"), Cells(x, 1)) = 0 Then
Range(Cells(x, 1), Cells(x, 3)).Copy
Range("J" & NyR).PasteSpecial
NyR = NyR + 1
Else
If Cells(x, 2) = "" Then
Cells(x, 2) = " "
End If
If Application.WorksheetFunction.CountIf(Range("K1:K10000"), Cells(x, 2)) = 0 Then
Range(Cells(x, 1), Cells(x, 3)).Copy
Range("J" & NyR).PasteSpecial
NyR = NyR + 1
Else
ROpslag = Application.Match(Cells(x, 1).Value & " - " & Cells(x, 2).Value, Range("I1:I10000"), 0)
NyC = Application.CountA(Range(Cells(ROpslag, 10), Cells(ROpslag, 20)))
For y = 3 To 6
If Application.WorksheetFunction.CountIf(Range(Cells(ROpslag, 12), Cells(ROpslag, 20)), Cells(x, 3)) = 0 Then
Cells(ROpslag, 10 + NyC) = Cells(x, y)
NyC = NyC + 1
End If
Next
End If
End If
Next
End Sub

Virker fint her, i hvilken linje får du fejl ?

Sub udRaderII()

rk = Cells(65536, "A").End(xlUp).Row

For Each r In Range("A2:A" & rk)

If r <> "" Then
  For Each t In Range("A" & r.Row + 1 & ":A" & rk)
    If t = r And r.Offset(0, 2) <> t.Offset(0, 2) And InStr(1, r.Offset(0, 3), t.Offset(0, 2)) = 0 Then
      r.Offset(0, 3) = r.Offset(0, 3) & "-" & t.Offset(0, 2)
      End If
    If t = r Then Range("A" & t.Row & ":C" & t.Row) = ""
  Next
End If

Next

Range("A2:A" & rk).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Shift:=xlUp

End Sub

@jens48 - Glædelig jul :-) Sætter stor pris på din hjælp!
Det ser ud til, at den seneste makro fejler når den rammer et felt i kolonne C som starter med et bogstav i stedet for tal. Kan det passe?
Og kan du i givet fald hjælpe mig videre?
PFT

@excelent - Glædelig jul og tak for hjælpen til dig også!
Du kan se fejlen jeg får her: https://drive.google.com/open?id=1d2JY0Jn2tRKuspfePEtr6Y-PdBd_E-va

Du kan sende en kopi eller et eks på dine data hvis jeg skal prøve
excelent@gefiber.dk

Kan pt. ikke teste det. Vil gerne vende tilbage efter nytår.Godt nytår

@jens48
Jeg oplever fortsat fejl når makroen kommer til en værdi i kolonne C der starter med et bogstav. Kan du hjælpe mig med at løse det?
Du kan eventuelt se hele mit dataark her: https://drive.google.com/open?id=1rgOnwbQx17laQ269NNdJO7nbof3GQcK2
Første gang jeg løber på fejlen er når A har værdi 10039.

Jeg har noget, som måske kan bruges, men jeg har problemer med dit dataark. Kan du ikke uploade et excel ark i stedet for en CSV fil.