Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Additional Code for Mr. Pearsons MergeDistinct Code
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Additional Code for Mr. Pearsons MergeDistinct Code
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Additional Code for Mr. Pearsons MergeDistinct Code
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 . |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Additional Code for Mr. Pearsons MergeDistinct Code
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 -- 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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Additional Code for Mr. Pearsons MergeDistinct Code
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.) "joel" wrote: 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 -- 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 . |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Help using Chip Pearsons code to count cells with color | Excel Discussion (Misc queries) | |||
add additional code to code | Excel Discussion (Misc queries) | |||
Help with C. Pearsons code to VBE | Excel Programming | |||
Add additional logic to my code | Excel Programming | |||
Additional feature to code given on August 6th | Excel Programming |