copy specific rows to a new sheet

[Guest]

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

 

[Norman Jones]

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
'<<================

 

[Norman Jones]

Hi Kim,


Re-reading your post, replace:

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

with

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

 

[Guest]

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]

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")

 

[Guest]

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

 

[Norman Jones]

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.

 

[Norman Jones]

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
'<<================

 

[Guest]

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

 

[Guest]

Sorry please ignore last post!

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

 

[Guest]

Thanks Norman that last code seems to have worked and done the job. One more
thing it puts the copied information in a new workbook is it possible to put
some code in there t0 save the workbook in my documents?
Thanks

 

[Norman Jones]

Hi Kim,

'------------------
Thanks Norman that last code seems to have worked and done the job. One more
thing it puts the copied information in a new workbook is it possible to put
some code in there t0 save the workbook in my documents?
'------------------

I assumed from your initial question that you wished to
create a new workbook to contain the copied data.

Now I am no longer sure of your intent.

Is the the original workbook to be saved under a new
name amd path?

 

[Guest]

Norman,
Sorry, your code does exactly that - it was a question at the end of a long
day!
Thank you for your patience and your expertise. Really appreciated.
Chris

 

[Guest]

This is an extension of the query above as Im trying to take this further.
I want to sort the columns before it is pasted into another worksheet .
I have tried the code
Sub sorted()
'
' sorted Macro
'
'

'
Range("A17381").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:= _
Range("C2"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
End Sub

This from copying a recorded macro - I tried to paste this into the code
Norman kindly supplied but can't get it to rub . Could anyone give me a few
tips?
Thanks

 

[Norman Jones]

Hi Kim.

Try keeping the sort routine as a separate procedure and call it from the
main procedure,

For example, try:

'================>>
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

Call MySort(Rng)

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

'-------------------->>
Public Sub MySort(Rng As Range)

With Rng
.Resize(, 4).Sort Key1:=.Range("B2"), _
Order1:=xlAscending, _
Key2:=.Range("C2"), _
Order2:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, _
DataOption2:=xlSortNormal
End With
End Sub
'<<=============