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" wrote:
>
> I familar with most of Chip's techniques. Not sure if I'm using the
> ones you are but this should work. I'm using a sumproduct formula to
> determine the 1st occurance of the items in column B. The SumProduct is
> in an evalkuate statement. You could add a column to the worksheet to
> 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 Sub
>
>
> --
> joel
> ------------------------------------------------------------------------
> joel's Profile: http://www.thecodecage.com/forumz/member.php?userid=229
> View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=149705
>
> .
>
Similar Threads
