Rick Rothstein said:
Thanks, but I still think there is a simpler underlying algorithm
available to solve this problem... I'll be looking again at this
problem a little bit later.
After getting my code working correctly, I still had one pesky question
rattling about inside my skull that just wouldn't go away:
Was there any really significant difference between my approach of doing
all the work "inside VBA" using arrays as contrasted with Rick's
approach of using worksheet methods?
That question bothered me enough I put together a little test to check
execution time. In the process, when I developed a random data generator
that resulted in sample data that contained *no* repeating values I
encountered the same error in Rick's code that GS reported - so I
implemented his solution of On Error Resume Next ... On Error Goto 0.
Likewise, my routine errored out when the array indices exceeded the
upper bound of the array. There, I had the choice of adding code to
place an upper limit on the array indices, or using "Resume Next". I
chose the latter.
Also, I discovered that execution time was fast enough that using the
Time function was useless ... so I borrowed a timeGetTime declared
function that I noticed Wouter post in a different thread recently.
Thanks, Wouter!
Results (looks better in notepad)
The second column is Rick's code, the third is mine:
Trial Elapsed time w/ range methods Elapsed time using arrays
1 27500 31
2 28703 31
3 30906 16
4 33016 31
5 34656 31
Average 30956 28
1200 values in Column A
800 values in Column B
Time in milliseconds
no duplicates (=rand())
After obtaining these results, I realized that my test data algorithm
was not producing any repeating values, so I added a ROUND function to
force duplicates and repeated the test:
Trial Elapsed time w/ range methods Elapsed time using arrays
1 7984 16
2 19531 16
3 25375 16
4 24984 16
5 25109 32
Average 20597 19
1200 values in Column A
800 values in Column B
Time in milliseconds
3 decmal places
The code I used follows. To repeat the test, paste all the following
code into a code module, and execute [ RunTest ].
The test parameters are all Constant declarations at the top of the
module; [ SetupTest ] contains some comment blocks that can be switched
around if you wish to keep copies of the test data worksheets so you can
see the data used in the trials.
As always, watch out for broken (wrapped) lines.
============== begin code ============
Option Explicit
Const TestRows As Long = 12
Const TestRows2 As Long = 8
Const NumberOfTrials As Long = 3
Const numDigits As Long = 3 ' number of places in random value
Declare Function timeGetTime Lib "winmm.dll" () As Long
'timeGetTime thanks to Wouter
Sub RunTest()
Dim elapsedTime(1 To 2) As Long
Dim startTime As Long
Dim stopTime As Long
Dim resultsRow As Long
Dim trialNumber As Long
Dim Results As Worksheet
Dim Test1 As Worksheet
Dim Test2 As Worksheet
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
Set Results = SetupResults
resultsRow = 2
With Sheets
Set Test1 = .Add(After:=Sheets(.Count))
Set Test2 = .Add(After:=Sheets(.Count))
End With
For trialNumber = 1 To NumberOfTrials
SetupTest Test1, Test2, trialNumber
Test1.Activate
startTime = timeGetTime
AlignColumnData
stopTime = timeGetTime
elapsedTime(1) = (stopTime - startTime)
Test2.Activate
startTime = timeGetTime
AlignData
stopTime = timeGetTime
elapsedTime(2) = (stopTime - startTime)
With Results.Rows(resultsRow)
.Cells(1) = trialNumber
.Cells(2) = elapsedTime(1)
.Cells(3) = elapsedTime(2)
End With
resultsRow = resultsRow + 1
Next trialNumber
With Results.Rows(resultsRow)
.Cells(1) = "Average"
.Cells(2) = "=AVERAGE(B2:B" & .Row - 1 & ")"
.Cells(2).AutoFill Destination:= _
Range(.Cells(2), .Cells(3)), Type:=xlFillDefault
End With
With Results
.Cells(resultsRow + 2, 2) = TestRows & " values in Column A"
.Cells(resultsRow + 3, 2) = TestRows2 & " values in Column B"
.Cells(resultsRow + 4, 2) = "Time in milliseconds"
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Results.Activate
End Sub
Function SetupResults() As Worksheet
Set SetupResults = Sheets.Add(After:=Sheets(Sheets.Count))
With SetupResults
.Cells(1).Formula = "Trial"
.Cells(2).Formula = "Elapsed time w/ range methods"
.Cells(3).Formula = "Elapsed time using arrays"
With .Columns("B:C")
.ColumnWidth = 15.43
'.NumberFormat = "0.00000"
.NumberFormat = "0"
.HorizontalAlignment = xlCenter
End With
With .Range("B1:C1")
.WrapText = True
End With
.Columns("A:A").HorizontalAlignment = xlCenter
.Name = "Results"
End With
End Function
Sub SetupTest(ByRef Test1 As Worksheet, _
ByRef Test2 As Worksheet, _
trialNumber As Long)
'''''''''''''''''''''''''''''''''''
' keep each trial worksheet
'Set Test1 = Sheets.Add(After:=Sheets(Sheets.Count))
'''''''''''''''''''''''''''''''''''
With Test1
.Cells(1).CurrentRegion.Clear
.Name = "Trial" & trialNumber
.Range(.Cells(1), .Cells(TestRows, 2)).Formula = _
"=ROUND(RAND()," & numDigits & ")"
.Calculate
With .Cells(1).CurrentRegion
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Application.CutCopyMode = False
.Range(.Cells(TestRows2 + 1, 2), .Cells(TestRows, 2)).Clear
.Columns(1).Sort .Cells(1, 1), xlAscending
.Columns(2).Sort .Cells(1, 2), xlAscending
'''''''''''''''''''''''''''''''''''
' keep each trial worksheet
' .Copy After:=Sheets(.Index)
' Set Test2 = Sheets(.Index + 1)
'''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''
' keep sheets of final trial only
Test2.Cells(1).CurrentRegion.Clear
.Cells(1).CurrentRegion.Copy _
Destination:=Test2.Cells(1)
'''''''''''''''''''''''''''''''''''
End With
End Sub
Sub AlignData()
'cm 3/18/11 using arrays
Dim ColAin As Variant ' Initial Column A Values
Dim ColBin As Variant ' Initial Column B Values
Dim Out As Variant ' Final Values
Dim LastColAin As Long ' Last Row
Dim LastColBin As Long
Dim LastOut As Long ' 'Current' (Last Used) Output Row
Dim idxColAin As Long ' 'Current' Input Row Index Pointer
Dim idxColBin As Long
Dim ThisColAin As Variant ' 'Current' Input Value
Dim ThisColBin As Variant
With WorksheetFunction
ColAin = .Transpose(Range("A1:A" & Cells(Rows.Count, _
"A").End(xlUp).Row + 1))
ColBin = .Transpose(Range("B1:B" & Cells(Rows.Count, _
"B").End(xlUp).Row + 1))
End With
LastOut = 0
idxColAin = 1
idxColBin = 1
ReDim Out(1 To 2, 1 To 1) ' initialize variant array structure; _
'redim preserve fails without this
Do
LastOut = LastOut + 1
ReDim Preserve Out(1 To 2, 1 To LastOut) ' columns, rows _
'because of how preserve works
On Error Resume Next
ThisColAin = ColAin(idxColAin)
ThisColBin = ColBin(idxColBin)
On Error GoTo 0
If IIf(IsEmpty(ThisColBin), ThisColAin, ThisColBin) > _
IIf(IsEmpty(ThisColAin), ThisColBin, ThisColAin) Then
' ColB is Larger: Copy ColA, ColB = Empty
Out(1, LastOut) = ThisColAin
idxColAin = idxColAin + 1
ElseIf IIf(IsEmpty(ThisColBin), ThisColAin, ThisColBin) _
= ThisColAin Then
' Same, copy both
Out(1, LastOut) = ThisColAin
Out(2, LastOut) = ThisColBin
idxColAin = idxColAin + 1
idxColBin = idxColBin + 1
Else ' ColA is Larger: Copy ColB, ColA = Empty
Out(2, LastOut) = ThisColBin
idxColBin = idxColBin + 1
End If ' ThisColBin <??> ThisColAin
Loop Until IsEmpty(ThisColAin) And IsEmpty(ThisColBin)
Range(Cells(1), Cells(LastOut, 2)) = _
WorksheetFunction.Transpose(Out)
End Sub
Sub AlignColumnData()
' Rick Rothstein Mon, 14 Mar 2011 20:21:08 -0400 [7:21 pm]
'Newsgroups: microsoft.public.Excel.programming
'Subject: Re: Align cells with same value - vba almost working
'Date: Tue, 15 Mar 2011 10:06:04 -0400 [9:06 am]
'comments added by cm
Dim X As Long, Data As Variant, Cell As Range
With Range("B1:B" & Cells(Rows.Count, "B").End(xlUp).Row)
Data = WorksheetFunction.Transpose(.Cells)
.Copy Cells(Rows.Count, "A").End(xlUp).Offset(1) ' copy "B" below
"A"
.Clear
End With
Columns("A").Sort Range("A1"), xlAscending
For X = 2 To Cells(Rows.Count, "A").End(xlUp).Row ' move dupes aligned
to col B
With Cells(X, "A")
If .Value = Cells(X - 1, "A").Value Then
.Offset(-1, 1).Value = Cells(X, "A").Value
.Clear
End If
End With
Next
On Error Resume Next
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete ' remove
empty rows
On Error GoTo 0
For X = LBound(Data) To UBound(Data) ' move unmatched B data aligned
to col B
With Columns("A").Find(Data(X), LookAt:=xlWhole)
' if B not empty then found value was (and now is aligned) in both
A and B
' if B is empty this found value was in B not in A so move it back
to B
If Len(.Offset(0, 1).Value) = 0 Then
.Copy .Offset(0, 1)
.Clear
End If
End With
Next
End Sub
