Additional Code for Mr. Pearsons MergeDistinct Code

[VickiMc]

I have adapted Mr. Pearsons MergeDistinct code for "Merging Lists to a List
of Distinct Values", if anyone is familiar with it.
What I would like the code to do first though is check that ColA contains
the one digit Code "A" then continue with evaluating ColB for unique values
to copy to the new list.
EG: in the table below, only rows 2, 3, & 4 would be assessed because ColA
contains an 'A", and then only Rows 2 & 3 would be copied to the new list
because they contain unique data in ColB.

1: B | Four
2: A | Five
3: A | Three
4: A | Five
5: C | One

Thank You (in anticipatiion)
Fond Regards
vicki

 

[joel]

I familar with most of Chip's techniques. Not sure if I'm using th
ones you are but this should work. I'm using a sumproduct formula t
determine the 1st occurance of the items in column B. The SumProduct i
in an evalkuate statement. You could add a column to the worksheet t
perfrom the same thing I'm doing with the Evaluate method.


Sub MoveData()

Set Sourcesht = Sheets("Sheet1")
Set DestSht = Sheets("Sheet2")

FirstRow = 1 'first row of source sheet
FindData = "A"
NewRow = 1 'first row of destination sheet

With Sourcesht.Columns("A")
Set c = .Find(what:=FindData, _
LookIn:=xlValues, lookat:=xlWhole)

If Not c Is Nothing Then
FirstAddr = c.Address
Do
'check if this is 1st occurance of column B
RowCount = c.Row
ColB = c.Offset(0, 1).Value
Myformula = "SUMPRODUCT(" & _
"(" & Sourcesht.Name & "!A$" & FirstRow & _
":A" & RowCount & "=""" & FindData & """)*" & _
"(" & Sourcesht.Name & "!B$" & FirstRow & _
":B" & RowCount & "=""" & ColB & """))"

Results = Evaluate(Myformula)
If Results = 1 Then
'first occurance copy data
c.EntireRow.Copy _
Destination:=DestSht.Rows(NewRow)
NewRow = NewRow + 1
End If
Set c = .FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> FirstAddr
End If
End With

End Su

 

[VickiMc]

Thanks Joel,
One question though, do I use this instead of, or in conjunction with the
MergeDistinct Code?

This is the code I have adapted to merge the two lists into one (I probably
should have placed this in the initial posting, sorry!).

My modifications included changing the ColumnToMatch, to ColumnToMatch1 &
ColumnToMatch2, as both columns are side by side (K and L) on the one
spreadsheet (as opposed to Column C on Sheets 1 & 2 as Mr. Pearson originally
designed the code to do).

Column E is the column on my spreadsheet I need the code to analyis before
it transfers the data from ColL, and then ColK to the (1column) list. NB: The
data in ColE is not transferred.



Sub MergeDistinct()
'MergeDistinct
'This procedure merges two lists into a separate list that contains no
duplicate values.

Dim R As Range 'Range loop variable
Dim LastCell As Range 'Last Cell in input columns
Dim WS As Worksheet 'Worksheet Reference
Dim N As Long 'Result of Duplicates test.
Dim M As Long 'Rows in merged list
Dim StartList1 As Range 'First Cell of first list to merge
Dim StartList2 As Range 'First Cell of second list to merge
Dim StartOutputList As Range 'First Cell of merged list
Dim ColumnToMatch1 As Variant 'Column in input lists to test for duplicates
Dim ColumnToMatch2 As Variant 'Column in input lists to test for duplicates
Dim ColumnsToCopy As Long 'Number of Columns in each input list to
copy to output.

'This is the column in the input lists that is to be tested for duplicates
ColumnToMatch1 = "L"
ColumnToMatch2 = "K"

'This is the number of columns from each list to be merged that are copied
to the result list.
ColumnsToCopy = 1

'The output list begins in this cell.
Set StartOutputList = Worksheets("Dwg_TakeOffs").Range("A2")

'The first list to be merged starts here
Set StartList1 = Worksheets("database").Range("L5")
Set WS = StartList1.Worksheet
With WS
M = 1
'get the last used cell in the first list to be merged
Set LastCell = .Cells(.Rows.Count, StartList1.Column).End(xlUp)
'loop though the range of values
For Each R In .Range(StartList1, LastCell)
If R.Value <> vbNullString Then
N = Application.CountIf(StartOutputList.Resize(M, 1), _
R.EntireRow.Cells(1, ColumnToMatch1).Text)
'if N = 0, then the item is not in the merged result
'list, so copy the data over. If N > 0, we've already
'encountered the value, so do nothing
If N = 0 Then
StartOutputList(M, 1).Resize(1, ColumnsToCopy).Value = _
R.Resize(1, ColumnsToCopy).Value
'M is the number of rows in the merged list. Increment it.
M = M + 1
End If
End If
Next R
End With

'The second list to be merged starts here.
Set StartList2 = Worksheets("Database").Range("K5")
Set WS = StartList2.Worksheet
With WS
Set LastCell = .Cells(.Rows.Count, StartList2.Column).End(xlUp)
For Each R In .Range(StartList2, LastCell)
If R.Value <> vbNullString Then
N = Application.CountIf(StartOutputList.Resize(M, 1), _
R.EntireRow.Cells(1, ColumnToMatch2).Text)
If N = 0 Then
StartOutputList(M, 1).Resize(1, ColumnsToCopy).Value = _
R.Resize(1, ColumnsToCopy).Value
M = M + 1
End If
End If
Next R
End With

End Sub

 

[joel]

I combined my code and your code together to get something that was
simplier. Chip's code was a general case example that made it easy to
modify, but was harder to understand that the results below. Your
original description wasn't extremely clear so I had to make some
modifications to my code. I also had to change my code to work with
both numbers and text. Your sample data was text, but when I tested
today I used numbers and found some of my code didn't work. I basically
changed Chip's COUNTIF to my SUMPRODUCT. SUMPRODUCT is needed since you
are comparing two columns.

I tested this code enough that I'm confident it will work "IF" your
posted code was correct.


Sub MergeDistinct()

Set Sourcesht = Worksheets("Dwg_TakeOffs")
Set DestSht = Worksheets("database")

FirstRow = 2 'first row of source sheet
NewRow = 1 'first row of destination sheet

With Sourcesht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 2 To LastRow
If .Range("K" & RowCount) <> "" Then
ColK = .Range("K" & RowCount).Text
ColL = .Range("L" & RowCount).Text
MyFormula = "SUMPRODUCT(" & _
"(Text(" & DestSht.Name & "!K$1" & _
":K" & NewRow & ",""@"")=""" & ColK & """)*" & _
"(Text(" & DestSht.Name & "!L$1" & _
":L" & NewRow & ",""@"")=""" & ColL & """))"
Results = Evaluate(MyFormula)

If Results = 0 Then
'first occurance copy data
..Rows(RowCount).Copy _
Destination:=DestSht.Rows(NewRow)
NewRow = NewRow + 1
End If
End If
Next RowCount
End With

End Sub

 

[VickiMc]

Thanks Joel, you've been most helpful and you're right it does work well.

The only difference is that Mr. Pearsons code copies only the one cell of
data contained in Column K or Column L (but not in both) and produces a
1column vector (List) on the destination sheet. (Yours copies the entire row.)

In laymens terms were you to do it the long way - one would use the
following steps

1) concatenate Columns E & K into Cell A1 on new a Worksheet. Then,
2) concatenate Columns E & L into Cell B1 on new a Worksheet. Then,
3) Cut-PasteSpecial-Values, both columns A & B, in-situ. Then,
4) Cut the data from Column B and append it below the data in Column A. Then,
5) Sort column A. Then,
6) Delete all the rows from the column that don't commence with 'A'. Then,
7) Put a formula in Column B that trimmed the first letter from the data in
Column A. Then,
8) Cut-PasteSpecial-Values, column B, insitu. Then,
9) Delete Entire Column A, such that Column B now becomes Column A. Then,
10) Sort Column A. And finally,
11) Manually going down the list, delete each row that contains duplicated
data - which gives you a list of unique values that appears either in column
K or Column L (but not both) of the original spreadsheet.
(NB: one could also write a MAX() to find the unique values, but I'm
guessing it is painfully obvious now what I'm trying to achieve - I think.)