تفضل الكود التالي .. قد لا يكون الحل هو الحل المثالي
Sub Test()
Const colOutput As Integer = 10
Dim e, rng As Range, lr As Long, r As Long, k As Long, n As Long, m As Long, ii As Long, t As Long
Application.ScreenUpdating = False
n = 1: k = 2
Columns("N:T").ClearContents
Cells(1, colOutput).CurrentRegion.Offset(1).ClearContents
For Each e In Array("A1", "E1")
Set rng = Range(e).CurrentRegion.Offset(1)
Set rng = rng.Resize(rng.Rows.Count - 1)
lr = Cells(Rows.Count, colOutput).End(xlUp).Row + 1
With Cells(1, Range(e).Column + 13).CurrentRegion
.ClearContents
.Cells(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
.Sort Key1:=.Cells(1, 2), Order1:=IIf(e = "A1", xlAscending, xlDescending), Header:=xlNo
End With
Next e
Do Until Cells(n, colOutput + 5) = Cells(n, colOutput + 9)
n = n + 1
Loop
If Cells(n, colOutput + 5) <> "" Then
m = 1
Do Until Cells(n, colOutput + 5) <> "" And Cells(n, colOutput + 5) <> Cells(n + m, colOutput + 5)
m = m + 1
Loop
If Cells(m + n, colOutput + 5) <> "" Then
ii = Cells(Rows.Count, colOutput + 4).End(xlUp).Row
Range(Cells(m + n, colOutput + 4), Cells(ii, colOutput + 6)).Cut
Cells(n, colOutput + 4).Insert Shift:=xlDown
End If
t = n
n = 1
Do Until Cells(n, colOutput + 5) = Cells(n, colOutput + 9)
If n >= t Then
Cells(k + 1, colOutput).Resize(, 3).Value = Cells(n, colOutput + 4).Resize(, 3).Value
Cells(k, colOutput).Resize(, 3).Value = Cells(n, colOutput + 8).Resize(, 3).Value
Else
Cells(k, colOutput).Resize(, 3).Value = Cells(n, colOutput + 4).Resize(, 3).Value
Cells(k + 1, colOutput).Resize(, 3).Value = Cells(n, colOutput + 8).Resize(, 3).Value
End If
k = k + 2
n = n + 1
Loop
Do Until Cells(n, colOutput + 5) = "" Or Cells(n, colOutput + 9) = ""
Cells(k, colOutput).Resize(, 3).Value = Cells(n, colOutput + 4).Resize(, 3).Value
Cells(k + 1, colOutput).Resize(, 3).Value = Cells(n, colOutput + 8).Resize(, 3).Value
n = n + 1
k = k + 2
Loop
If Cells(n, colOutput + 5) = "" And Cells(n, colOutput + 9) <> "" Then
ii = Cells(Rows.Count, colOutput + 8).End(xlUp).Row
Range(Cells(n, colOutput + 8), Cells(ii, colOutput + 10)).Copy
Cells(k, colOutput).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
If Cells(n, colOutput + 5) <> "" And Cells(n, colOutput + 9) = "" Then
ii = Cells(Rows.Count, colOutput + 4).End(xlUp).Row
Range(Cells(n, colOutput + 4), Cells(ii, colOutput + 6)).Copy
Cells(k, colOutput).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End If
End If
Columns("N:T").ClearContents
Application.ScreenUpdating = True
End Sub