View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
Norman Jones Norman Jones is offline
external usenet poster
 
Posts: 5,302
Default copy specific rows to a new sheet

Hi Kim,

'-------------------
I have several rows of information in a worksheet I need a macro or code to
select only the rows that do not have the word "keep" anywhere in them,
copy
those rows and open a new workbook and paste them into the worksheet then
save the worksheet in my documents with month as the filename.
I manage to do this with a macro selecting specific rows by drag and select
but the layout changes so this no good.
'-------------------

Try something like;

'================
Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim destSH As Worksheet
Dim rng As Range
Dim rCell As Range
Dim Rng2 As Range
Dim iRow As Long
Dim CalcMode As Long
Const sStr As String = "keep" '<<===== CHANGE

Set WB = Workbooks("MyBook.xls") '<<===== CHANGE
Set SH = WB.Sheets("Sheet1") '<<===== CHANGE

With SH
iRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set rng = SH.Range("A1:A" & iRow)
End With

On Error GoTo XIT
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With


For Each rCell In rng.Cells
If Application.CountIf( _
rCell.EntireRow, "*" & sStr & "*") Then
If Rng2 Is Nothing Then
Set Rng2 = rCell
Else
Set Rng2 = Union(rCell, Rng2)
End If
End If
Next rCell

If Not Rng2 Is Nothing Then
With WB
Set destSH = .Worksheets.Add( _
After:=.Sheets(.Sheets.Count))
End With

With destSH
Rng2.Copy Destination:=destSH.Range("A1")
.Name = Format(Date, "mmmm")
.Copy
End With

With ActiveWorkbook
.SaveAs Filename:=destSH.Name & ".xls"
.Close SaveChanges:=False
End With
End If

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<================


---
Regards,
Norman