Joe,
I'm not sure which function you are after exactly. Here is my entire
macro.. It may not be the tidiest code in the world, but it's doing the job..
Hope it helps you -kelli
Sub CullSort()
'
'Copies and Pastes values for entire sheet to eliminate formulas
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
'Sorts by "Master" (Column P) so that following removal sequence runs faster
Cells.Select
Selection.Sort Key1:=Range("P2"), Order1:=xlDescending, Header:=xlGuess,
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
'Removes entire row for unwanted records based on calculated formulas in
Column P
Dim rng As Range
Dim rCell As Range
Dim delRng As Range
Dim WB As Workbook
Dim SH As Worksheet
Dim CalcMode As Long
Set WB = ActiveWorkbook
Set SH = WB.Sheets("Prelim")
Set rng = Intersect(SH.UsedRange, SH.Columns("P
"))
On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In rng.Cells
If rCell.Value = "DELETE" Then
If delRng Is Nothing Then
Set delRng = rCell
Else
Set delRng = Union(rCell, delRng)
End If
End If
Next rCell
If Not delRng Is Nothing Then
delRng.EntireRow.Delete
End If
XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
' Blanks out zero quantities in all Qty columns (note to self: there is
probably a faster way to do this)
Dim list As Integer
For list = 1 To 20000
If Cells(list, 8) = "0" Then
Cells(list, 8) = ""
End If
If Cells(list, 9) = "0" Then
Cells(list, 9) = ""
End If
If Cells(list, 11) = "0" Then
Cells(list, 11) = ""
End If
If Cells(list, 12) = "0" Then
Cells(list, 12) = ""
End If
Next
'
'Removes now unnecessary formula columns and pastes some results over
original data
Columns("T:T").Select
Selection.Cut
Columns("N:N").Select
ActiveSheet.Paste
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("O:R").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
'Copies all rows where B is not empty and pastes values in pre-existing sheet2
Dim FirstCell As Range
Dim LastCell As Range
Dim destRng As Range
Set destRng = WB.Sheets("Buyer").Range("A2")
If Not IsEmpty(SH.Range("B2")) Then
Set FirstCell = SH.Range("A2")
Else
Set FirstCell = SH.Range("A2").End(xlDown)
End If
Set LastCell = SH.Cells(Rows.Count, "B").End(xlUp)
SH.Range(FirstCell, LastCell).EntireRow.Copy
destRng.PasteSpecial Paste:=xlPasteValues,
Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Formats and sorts "Buyer" sheet
Sheets("Buyer").Select
Cells.Select
Selection.Columns.AutoFit
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("D2"),
Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal,
DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Range("A2").Select
'Duplicates "Buyer" data in "Floor" sheet
Sheets("Buyer").Select
Set destRng = WB.Sheets("Floor").Range("A1")
Cells.Select
Selection.Copy
destRng.PasteSpecial xlPasteAll, xlPasteSpecialOperationNone,
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
'Deletes entire row in "Floor" for records when H is blank or < 0
Dim ViewMode As Long
Dim rngCurrentCell As Range
Dim rowDel As Range
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
Sheets("Floor").Select
Range("A2").Select
With ActiveSheet
.DisplayPageBreaks = False
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 0).Resize(tbl.Rows.Count - 1, tbl.Columns.Count).Select
For Each rngCurrentCell In Worksheets("Floor").Range("H:H").Cells
If IsEmpty(rngCurrentCell) Or rngCurrentCell.Value < 0.01 Or
rngCurrentCell.Value = "" Then
If rowDel Is Nothing Then
Set rowDel = rngCurrentCell
Else
Set rowDel = Application.Union(rowDel, rngCurrentCell)
End If
End If
Next
End With
If Not rowDel Is Nothing Then
rowDel.EntireRow.Delete
End If
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
Range("A2").Select
Sheets("Buyer").Select
Range("A2").Select
Sheets("Prelim").Delete
End Sub
jkrist46 said:
Can you send me this. I have to do the same thing except cut it into another
worksheet tab.
Thanks Joe
Norman... If it's not too presumptuous of me, may I ask one more favor? I
now just need to select and copy all rows for which B is populated. At this
point, all the records with data in B are grouped and there are no empty rows
after the last record. You've been great and I really appreciate the help!
-kelli
[quoted text clipped - 60 lines]
empties the non-empty empty cells? Does knowtrumps code do that?
-Tks guys!
