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
|