Complicated Sort-Compare-Delete Question

[JohnTNiman - ExcelForums.com]

At least for me. I'm trying to work on a macro that does severa
things, and I've hit a stumbling block. Of course, I didn't know th
first thing about VBA yesterday, so I think my learning curve ha
been okay

Here's what the macro needs to do

Find a Range of cells in one workbook (In this case Sold-KBH001
01.xls). This range will not always be the same, and can begin an
end on different cells each time. Bonus points if this can work i
any sheet and not just this one

Select columns B,C,D,F,G,O of this range

Copy them into columns K,L,M,N,P,R of a different work book (thes
rows will always start at A-2 in this work book, but will end i
different places and I need to be able to copy one blank row an
insert as many new rows as there were lines in the selected rang
above to retain the formulas.) This new workbook is (and can alway
be) named P0020 Purchase Order Master.xls

I then need to sort the new range by column K and check fo
duplicate entries. If there is a duplicate entry that matche
Manufacturer Number (Column K) Model (Column L) and Price (Column P
then I need to add the duplicate's quantity (Column N) to th
Original's quantity and delete the duplicate line

Finally, I need the workbook to auto save as a new book

Here is the code that I've written so far. It's been hacked togethe
from bits and pieces I can gather from a college text book an
internet searches, so I'm sure it's not pretty. I've gotten throug
most everything except the checking for duplicates portion though
Thank you, so much, in advance for your help

Sub Everything_So_Far(

`This code asks the user where the cell range begins and ends

Dim FirstNumber As Strin
Dim SecondNumber As Strin
Dim intLoopIndex As Intege
Dim intMaximum As Intege
intMaximum = 15

FirstNumber = InputBox("Enter the cell where the data begins:"
SecondNumber = InputBox("Enter the cell where the data ends:"

`This copys and pastes the selected range into a new sheet an
`deletes unneccessary column

Range(FirstNumber, SecondNumber).Selec
Selection.Cop

Sheets.Ad
ActiveSheet.Past

Sheets("Assumptions").Selec
Sheets.Ad
ActiveSheet.Past

Columns("B:B").Selec
Application.CutCopyMode = Fals
Selection.Cop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks
:=False, Transpose:=Fals
Columns("C:C").Selec
Application.CutCopyMode = Fals
Selection.Cop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks
:=False, Transpose:=Fals
Columns("D").Selec
Application.CutCopyMode = Fals
Selection.Cop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks
:=False, Transpose:=Fals
Columns("F:F").Selec
Application.CutCopyMode = Fals
Selection.Cop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks
:=False, Transpose:=Fals
Columns("G:G").Selec
Application.CutCopyMode = Fals
Selection.Cop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks
:=False, Transpose:=Fals
Columns("O:O").Selec
Application.CutCopyMode = Fals
Selection.Cop
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
SkipBlanks
:=False, Transpose:=Fals
Range("A:A,E:E,H:N,P:Z").Selec
Range("H1").Activat
Application.CutCopyMode = Fals
Selection.Delete Shift:=xlToLef
Range("A:A,E:E,H:N,P:Z").EntireColumn.AutoFi
Columns("B:B").EntireColumn.AutoFi
Columns("C:C").EntireColumn.AutoFi
Columns("D").EntireColumn.AutoFi
Range("A:A,E:E,H:N,P:Z").EntireColumn.AutoFi
Columns("F:F").EntireColumn.AutoFi

`This code inserts 300 rows of copied cells (the most I can envisio
`needing), pastes the collumns from the created sheet into the shee
`I want them in, and then deletes all unused rows

For intLoopIndex = 0 To intMaximu

Windows("P0020 Purchase Order Master.xls").Activat
Rows("3:4").Selec
Selection.Cop
Selection.Insert Shift:=xlDow
Next intLoopInde

Range("K2").Selec
Windows("SOLD-KBH001-01.xls").Activat
Range("A1:A300").Selec
Application.CutCopyMode = Fals
Selection.Cop
Windows("P0020 Purchase Order Master.xls").Activat
ActiveSheet.Past
Range("L2").Select

Range("L2").Select
Windows("SOLD-KBH001-01.xls").Activate
Range("B1:B300").Select
Application.CutCopyMode = False
Selection.Copy
Windows("P0020 Purchase Order Master.xls").Activate
ActiveSheet.Paste
Range("M2").Select

Range("M2").Select
Windows("SOLD-KBH001-01.xls").Activate
Range("C1:C300").Select
Application.CutCopyMode = False
Selection.Copy
Windows("P0020 Purchase Order Master.xls").Activate
ActiveSheet.Paste
Range("N2").Select

Range("N2").Select
Windows("SOLD-KBH001-01.xls").Activate
Range("D1300").Select
Application.CutCopyMode = False
Selection.Copy
Windows("P0020 Purchase Order Master.xls").Activate
ActiveSheet.Paste
Range("P2").Select

Range("P2").Select
Windows("SOLD-KBH001-01.xls").Activate
Range("E1:E300").Select
Application.CutCopyMode = False
Selection.Copy
Windows("P0020 Purchase Order Master.xls").Activate
ActiveSheet.Paste
Range("R2").Select

Range("R2").Select
Windows("SOLD-KBH001-01.xls").Activate
Range("F1:F300").Select
Application.CutCopyMode = False
Selection.Copy
Windows("P0020 Purchase Order Master.xls").Activate
ActiveSheet.Paste
Range("A1").Select

Columns("K:K").EntireColumn.AutoFit
Columns("L:L").EntireColumn.AutoFit
Columns("M:M").EntireColumn.AutoFit
Columns("N:N").EntireColumn.AutoFit
Columns("P").EntireColumn.AutoFit
Columns("Q:Q").EntireColumn.AutoFit
Columns("R:R").EntireColumn.AutoFit
Windows("SOLD-KBH001-01.xls").Activate
Sheets("Sheet1").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet2").Select
ActiveWindow.SelectedSheets.Delete
Windows("P0020 Purchase Order Master.xls").Activate

Range("K2", "K308").Select
On Error Resume Next
Selection.SpecialCells(xlCellTypeBlanks).EntireRow .Delete
ActiveSheet.UsedRange

`The remainder of the code is me trying to figure out how to find
`duplicates and handle all the manipulation that needs to be done
`with them.


Dim StartingMan As String
Dim NextMan As String
Dim StartingModel As String
Dim NextModel As String
Dim StartingPrice As Currency
Dim NextPrice As Currency
Dim Hold As Variant
Dim StartingQuantity
Dim NewQuantity

StartingMan = Range("k2")
StartingModel = Range("L2")
StartingPrice = Range("P2")
Hold = 0

If StartingMan = NextMan And StartingModel = NextModel And
StartingPrice = NextPrice Then




End Sub

 

[Guest]

OK I'll have a go. The macro below addresses only the deletion of duplicate
rows once all the copying, pasting etc has been done by your code. I have
assumed that column T is blank. Save your data before trying this - no undo
afterwards.

Sub DelThem()

Dim lRow As Long
Dim tCode As String
Dim fCode As String
Dim colK As Range
Dim chk As Range
Dim l As Long
Dim counter As Long

On Error GoTo ErrorHandler
Application.ScreenUpdating = False

'find last row
lRow = Cells(Rows.Count, 11).End(xlUp).Row
'set range = all data in column K
Set colK = Range(Cells(2, 11), Cells(lRow, 11))

'loop through column K
For Each chk In colK
'if column T already populated then do nothing
If chk.Offset(0, 9).Value = Empty Then
'if column T not populated then mark to keep row
chk.Offset(0, 9).Value = "keep"
'Set variable tCode = Man Code + Model + Price
tCode = chk.Value & chk.Offset(0, 1).Value & _
chk.Offset(0, 5).Value
'Check rest of data to bottom
For l = chk.Row + 1 To lRow
'set variable fCode = Man Code + Model + Price
fCode = Cells(l, 11).Value & Cells(l, 12).Value & _
Cells(l, 16).Value
'if Man Code + Model + Price equal then...
If fCode = tCode Then
'add qty from this row to row being checked
chk.Offset(0, 3).Value = chk.Offset(0, 3).Value + _
Cells(l, 14).Value
'mark row for deletion
Cells(l, 20).Value = "delete"
End If
'compare next row to row being checked
Next l
End If
'check next row
Next chk

'start at bottom and delete all rows marked for deletion
For counter = l To 2 Step -1
If Cells(counter, 20).Value = "delete" Then
Cells(counter, 20).EntireRow.Delete
End If
Next counter

'clear contents of column T
Columns(20).ClearContents

ErrorHandler:
Application.ScreenUpdating = True

End Sub

I haven't really looked at the rest of your code in detail but it could use
a bit of cleaning up. Remember you don't have to select cells in order to
perform an operation on them so for example:

Columns("B:B").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Columns("C:C").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Columns("D").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

could be rewritten as

With Range("B")
.Value = .Value
End With

Hope this helps
Rowan

PS you could adapt this to do your file saving. Allows the user to chose
folder and filename

Sub SaveIt()
Dim fFilter As String
Dim flName As Variant
fFilter = "Excel Files (*.xls), *.xls"
flName = Application.GetSaveAsFilename(, fFilter)
If flName = False Then
Exit Sub
Else
ThisWorkbook.SaveAs Filename:=flName, _
FileFormat:=xlWorkbookNormal
End If
End Sub

 

[JohnNiman]

Rowan,

THANK YOU!

It works *almost* perfectly. I think that the comparison formula i
missing something though. If, for instance, I have three items, all o
which have the same model number, description and quantity ordered, bu
for some reason one of the prices is different, they are all combine
under one heading with quantity of three, as opposed to two heading
with quantities on 2 and 1.

Did that make sense?

Any thoughts on how to add that?

On a side note, I know my code is horribly sloppy. I've got the basic
of VBA down, but this has been chopped together from recording an
manipulating what I want and looking for examples on the internet
Someone who really knew what they were doing could probably cut 10
lines out

Thank you again, I appreciate the help a lot

 

[Guest]

Hi John

I am not sure I have completely understood your question.

The way it is currently working is to check the Manufacturer in column K,
the model in Column L and the Price in column P. It these are all the same
then the quantities in column N are added together and the extra line is
deleted. So if you had 3 records with a qty of 1 each and the same
manufacturer, model and price you will be left with one record with a qty of
3. That is how it is currently working for me.

If one of the prices is different then you should be left with two records
one with a qty of 2 and the other with 1. It should do that currently. Is
this what you are after or do you want all three of those records added
together? If this is the case, which price would you keep?

Regards
Rowan

 

[Guest]

Hi John

I am going to be offline from now until Monday morning Australian Eastern
Standard Time. I'll check back then

Regards
Rowan