2 problems
Posted by Ken McLane on March 03, 2000 10:20 AM
I am fairly new to this, and I have a couple of problems.
1. I have a list of products, columns of: MANUFACTURER, MODEL, PART #,
DESCRIPTION, COST and PRICE. I am looking for a way to check the model
column to see if it contains certain words, and if so, cut the entire
row and paste it to another sheet. There are three or four different
words I need to key on. These words are always at the right end of the
column. I have about 4000 rows of data.
2. After that, I need to integrate what is left with an existing list,
comparing the two and eliminating duplicate rows. I have been doing this
by hand. I basically need to add the new items off the list and discard
the items that are redundant.
I have put a lot of the information on your site into practice and it
has saved me tons of work. I have tried to apply the techniques I see
here to this but I am not experiencing a lot of success. Thank you for
any help you can offer.
I am using Excel 97.
Posted by Celia on March 11, 2000 1:53 AM
Ken
(1).Try the macro below.
It assumes that there are no blank cells in the MODEL column (column B) of your product list.
The models that are cut and paste have at the right end of column B the word One or Two or Three or Four.
The cut rows are pasted to a different sheet called New List.
I suggest you test it first on a small list rather than one with 4000 items.
Sub CutAndPaste()
Dim model As Range
Dim list As Range
Dim newList As Range
Set list = Range(Range("B2"), Range("B2").End(xlDown))
Set newList = Sheets("New List"). Rows("65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False
For Each model In list
If Right(model, 3) = "One" Or _
Right(model, 3) = "Two" Or _
Right(model, 5) = "Three" Or _
Right(model, 4) = "Four" Then
model.EntireRow.Copy
ActiveSheet.Paste newList
Set newList = newList.Offset(1, 0)
End If
Next model
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
(2).To compare what is left on the original list with an existing list, there have been a number of questions and replies about this posted on this board during the past month.You can probably find what you need by looking back a bit.
Alternatively, you can copy the whole of what is left on the original list, add it to the bottom of the existing list, and then sort into sequence(must sort because the following macro compares each row with the next one).
After sorting, run the macro shown below (I didnt write it but cant remember where I got it from).You must select he rows first the easiest way is to select the whole sheet.
This macro will delete duplicate rows only if the data in all columns are the same.
Sub DeleteDuplicates()
Dim iRows As Long
Dim iCols As Long
Dim RowMax As Long
Dim ColMax As Long
Dim bSame As Boolean
Dim rowMin As Long
Dim colMin As Long
'restrict range to check to just cells in the used range
With Intersect(Selection, ActiveSheet.UsedRange)
'make certain there are at least two rows
If Selection.Rows.Count = 1 Then
MsgBox "Pick more rows!"
Exit Sub
End If
'make certain only one range is selected
If .Areas.Count > 1 Then
MsgBox "Only a single area is allowed"
Exit Sub
End If
'set min and max columns numbers
rowMin = .Cells(1).Row + 1
RowMax = .Cells(.Cells.Count).Row
colMin = .Cells(1).Column
ColMax = .Cells(.Cells.Count).Column
End With
'check rows, starting from the bottom and working up
For iRows = RowMax To rowMin Step -1
'initialize each time
bSame = True
'check column values
For iCols = colMin To ColMax
If Cells(iRows, iCols).Value <> _
Cells(iRows - 1, iCols).Value Then
'if a difference is found set bSame to False
bSame = False
Exit For
End If
Next
'if bSame still true, delete the row
If bSame Then Rows(iRows).Delete
Next
End Sub
Celia
