Hi
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.
Help appreciated
Thanks

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

Hi Kim,


Re-reading your post, replace:

> If Application.CountIf( _
> rCell.EntireRow, "*" & sStr & "*") Then


with

If Application.CountIf( _
rCell.EntireRow, "*" & sStr & "*") = 0 Then


---
Regards,
Norman

Thanks Norman it produced the workbook but no data pasted. I moved my data to
cell A1 tried again . It did paste only the rows but only the data in column
A how can get to paste data from the other columns?
I tried to figure this out by looking a t the code but can't get there!
Thanks

"Norman Jones" wrote:

> Hi Kim,
>
>
> Re-reading your post, replace:
>
> > If Application.CountIf( _
> > rCell.EntireRow, "*" & sStr & "*") Then
>
>
> with
>
> If Application.CountIf( _
> rCell.EntireRow, "*" & sStr & "*") = 0 Then
>
>
> ---
> Regards,
> Norman
>
>
>

Hi Kim,

'------------------
Thanks Norman it produced the workbook but no data pasted. I moved my data
to
cell A1 tried again . It did paste only the rows but only the data in column
A how can get to paste data from the other columns?
I tried to figure this out by looking a t the code but can't get there!
'------------------

(1) Change:

> Set rng = SH.Range("A1:A" & iRow)

to reflect a column which encompasses all of your data.


(2) Change

> Rng2.Copy Destination:=destSH.Range("A1")

to:

Rng2EntireRow.Copy Destination:=destSH.Range("A1")


---
Regards,
Norman

Hi Norman
I chaged the range in the code from A1:A to A1:Z400
This caught the data was this the correct approach?
Thanks

"kim" wrote:

> Thanks Norman it produced the workbook but no data pasted. I moved my data to
> cell A1 tried again . It did paste only the rows but only the data in column
> A how can get to paste data from the other columns?
> I tried to figure this out by looking a t the code but can't get there!
> Thanks
>
> "Norman Jones" wrote:
>
> > Hi Kim,
> >
> >
> > Re-reading your post, replace:
> >
> > > If Application.CountIf( _
> > > rCell.EntireRow, "*" & sStr & "*") Then
> >
> >
> > with
> >
> > If Application.CountIf( _
> > rCell.EntireRow, "*" & sStr & "*") = 0 Then
> >
> >
> > ---
> > Regards,
> > Norman
> >
> >
> >

Hi Kim,

'----------------
I chaged the range in the code from A1:A to A1:Z400
This caught the data was this the correct approach?
'----------------

See my response to your previous post..

However, it should be necessary only to replace 'A'
with a column that defines the last data row.

To copy the entire data rows, adopt also my second
suggestion.


---
Regards,
Norman

Hi Kim,

To avoid the potential problem of column specification,
try the following version:

'================>>
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 = LastRow(sh)
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 & "*") = 0 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.EntireRow.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

'--------------->
Function LastRow(sh As Worksheet, _
Optional rng As Range)
If rng Is Nothing Then
Set rng = sh.Cells
End If

On Error Resume Next
LastRow = rng.Find(What:="*", _
After:=rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<================


---
Regards,
Norman

Hi Norman
Looking at this, away from the code ,for what I need to record it makes more
sense to have the code copy the rows where the word "Keep" does not appear is
it possible to change the code to do this?
Thanks for your help

"Norman Jones" wrote:

> Hi Kim,
>
> '------------------
> Thanks Norman it produced the workbook but no data pasted. I moved my data
> to
> cell A1 tried again . It did paste only the rows but only the data in column
> A how can get to paste data from the other columns?
> I tried to figure this out by looking a t the code but can't get there!
> '------------------
>
> (1) Change:
>
> > Set rng = SH.Range("A1:A" & iRow)
>
> to reflect a column which encompasses all of your data.
>
>
> (2) Change
>
> > Rng2.Copy Destination:=destSH.Range("A1")
>
> to:
>
> Rng2EntireRow.Copy Destination:=destSH.Range("A1")
>
>
> ---
> Regards,
> Norman
>
>
>

Sorry please ignore last post!


"kim" wrote:

> Hi Norman
> Looking at this, away from the code ,for what I need to record it makes more
> sense to have the code copy the rows where the word "Keep" does not appear is
> it possible to change the code to do this?
> Thanks for your help
>
> "Norman Jones" wrote:
>
> > Hi Kim,
> >
> > '------------------
> > Thanks Norman it produced the workbook but no data pasted. I moved my data
> > to
> > cell A1 tried again . It did paste only the rows but only the data in column
> > A how can get to paste data from the other columns?
> > I tried to figure this out by looking a t the code but can't get there!
> > '------------------
> >
> > (1) Change:
> >
> > > Set rng = SH.Range("A1:A" & iRow)
> >
> > to reflect a column which encompasses all of your data.
> >
> >
> > (2) Change
> >
> > > Rng2.Copy Destination:=destSH.Range("A1")
> >
> > to:
> >
> > Rng2EntireRow.Copy Destination:=destSH.Range("A1")
> >
> >
> > ---
> > Regards,
> > Norman
> >
> >
> >