OK, her er et bud:
Forudsætning: Ark3 skal eksistere i forvejen og være tomt.
Da jeg kun har testet på små mængder data, ved jeg ikke rigtigt hvor hurtigt det går; det kan godt tage et stykke tid.......
Sub LavNytArk3()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long
Sheets(1).Select
i = Range("a2").End(xlDown).Row
Dim KundeNr1() As Long
ReDim KundeNr1(2 To i)
Sheets(2).Select
i = Range("a2").End(xlDown).Row
Dim KundeNr2() As Long
ReDim KundeNr2(2 To i)
Dim RowNr1x() As Long
Dim RowNr2x() As Long
For i = 2 To UBound(KundeNr2)
KundeNr2(i) = Cells(i, 1)
Next i
Sheets(1).Select
For i = 2 To UBound(KundeNr1)
KundeNr1(i) = Cells(i, 1)
Next i
For i = 2 To UBound(KundeNr1)
For j = 2 To UBound(KundeNr2)
If KundeNr1(i) = KundeNr2(j) Then
ReDim Preserve RowNr1x(k)
ReDim Preserve RowNr2x(k)
RowNr1x(k) = i
RowNr2x(k) = j
KundeNr1(i) = 0
KundeNr2(j) = 0
k = k + 1
End If
Next j
Next i
k = 2
For i = 2 To UBound(KundeNr1)
Sheets(1).Select
If Not KundeNr1(i) = 0 Then
Range(Cells(i, 1), Cells(i, 5)).Select
Selection.Copy
Sheets(3).Select
Range(Cells(k, 1), Cells(k, 5)).Select
ActiveSheet.Paste
k = k + 1
End If
Next i
For i = 2 To UBound(KundeNr2)
Sheets(2).Select
If Not KundeNr2(i) = 0 Then
Range(Cells(i, 2), Cells(i, 8)).Select
Selection.Copy
Sheets(3).Select
Cells(k, 1) = KundeNr2(i)
Range(Cells(k, 6), Cells(k, 12)).Select
ActiveSheet.Paste
k = k + 1
End If
Next i
For i = 0 To UBound(RowNr1x)
Sheets(1).Select
Range(Cells(RowNr1x(i), 1), Cells(RowNr1x(i), 5)).Select
Selection.Copy
Sheets(3).Select
Range(Cells(k, 1), Cells(k, 5)).Select
ActiveSheet.Paste
Sheets(2).Select
Range(Cells(RowNr2x(i), 2), Cells(RowNr2x(i), 8)).Select
Selection.Copy
Sheets(3).Select
Range(Cells(k, 6), Cells(k, 12)).Select
ActiveSheet.Paste
k = k + 1
Next i
Application.ScreenUpdating = True
End Sub
Det kan godt være der skal nogle små tilretninger til, så tager vi den derfra..........
