Align cells with same value - vba almost working
Here are slightly shorter versions of my code, one assuming the data in both
columns are in sorted order before the macro is run and the other allowing
the data to be sorted or not sorted...
'===================================
' Data Pre-sorted
'===================================
Sub AlignColumnData()
Dim M As Long, D As Long, Rw As Long, TempM As Long, Main, Data
With WorksheetFunction
Main = .Transpose(Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row))
Data = .Transpose(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
Range("A:B").Clear
M = LBound(Main)
D = LBound(Data)
Do While M + D <= UBound(Main) + UBound(Data)
Rw = Rw + 1
Range("A" & Rw).Offset(0, -(Main(M) Data(D))).Resize(1, _
1 - (Main(M) = Data(D))) = .Min(Main(M), Data(D))
TempM = Main(M)
M = M - (Main(M) <= Data(D))
D = D - (TempM = Data(D))
Loop
End With
End Sub
'===================================
' Data Not Necessarily Sorted
'===================================
Sub AlignColumnData()
Dim M As Long, D As Long, Rw As Long, TempM As Long, Main, Data
Columns("A").Sort Range("A1"), xlAscending
Columns("B").Sort Range("B1"), xlAscending
With WorksheetFunction
Main = .Transpose(Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row))
Data = .Transpose(Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row))
Range("A:B").Clear
M = LBound(Main)
D = LBound(Data)
Do While M + D <= UBound(Main) + UBound(Data)
Rw = Rw + 1
Range("A" & Rw).Offset(0, -(Main(M) Data(D))).Resize(1, _
1 - (Main(M) = Data(D))) = .Min(Main(M), Data(D))
TempM = Main(M)
M = M - (Main(M) <= Data(D))
D = D - (TempM = Data(D))
Loop
End With
End Sub
Rick Rothstein (MVP - Excel)
|