how to sort (by one field), copy (based on one field) to another tab,then clear data on original she

M

Mel

I have a spreadsheet with 2 tabs. Pension Log and Pension Log
closed. On the Pension Log, I can sort by a number of fields. This
is the macro I have set up to run for the sort:

Sub Sort_Status()
'
' Sort_Name Macro
'
ActiveSheet.Unprotect
Range("A1:L3654").Select
Selection.Sort Key1:=Range("j2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True
End Sub

Pension Closed Log is the same as the Pension log but just closed
items only.
Cell J2 is the status field. It is either an O, I, H or C (C for
closed). I can sort this log so that all the closed lines are
together.

What I want to do is via a manual process (macro button) sort and copy
all closed lines over to the Pension closed log and then clear
contents on the closed rows (but leave conditional formulas)on the
pension log (originator). Pension log is from Cell A2 to L3654.

The pension closed log would just keep adding (next blank row down)
any closed items from the Pension log for about a year. This might be
run once a month or so.

By setting this up, I want to be able to keep only active rows on the
Pension Log and be able to automate the sort and copy/move of the
closed rows over to the Pension closed log. Presently users are using
cut and paste causing format and conditional formatting problems.

I have the sort function down, but have not been able to write the
script to select only rows that equal 'C' in field J2, then copy to
the next blank row on the tab 'Pension log closed' and the last is
clear contents of any row on the original Pension Log that indicates a
'C' in field J2.

thx
Mel
 
P

Per Jessen

Hi

Try this (untested). Check sheet names and add code to unprotect TargetSh if
required:

Sub Sort_Status_And_Copy_Closed()

'
Dim OrgSh As Worksheet
Dim TargetSh As Worksheet
Dim TargetRange As Range
Dim ClosedRange As Range
Dim CopyToCell As Range

Set OrgSh = Worksheets("Pension Log")
Set TargetSh = Worksheets("Pension Closed Log")
Set TargetRange = OrgSh.Range("A1", OrgSh.Range("L" & Rows.Count).End(xlUp))
Set CopyToCell = TargetSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
OrgSh.Unprotect
TargetRange.Sort Key1:=Range("j2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
TargetRange.AutoFilter Field:=10, Criteria1:="C"
Set ClosedRange = TargetRange.SpecialCells(xlCellTypeVisible)
TargetRange.AutoFilter
ClosedRange.Copy
CopyToCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ClosedRange.ClearContents
Set ClosedRange=Nothing
Range("A2").Select
OrgSh.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowSorting:=True
End Sub

Regards,
Per
 
M

Mel

Hi

Try this (untested). Check sheet names and add code to unprotect TargetShif
required:

Sub Sort_Status_And_Copy_Closed()

'
Dim OrgSh As Worksheet
Dim TargetSh As Worksheet
Dim TargetRange As Range
Dim ClosedRange As Range
Dim CopyToCell As Range

Set OrgSh = Worksheets("Pension Log")
Set TargetSh = Worksheets("Pension Closed Log")
Set TargetRange = OrgSh.Range("A1", OrgSh.Range("L" & Rows.Count).End(xlUp))
Set CopyToCell = TargetSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
OrgSh.Unprotect
TargetRange.Sort Key1:=Range("j2"), Order1:=xlAscending, _
    Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
    Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
TargetRange.AutoFilter Field:=10, Criteria1:="C"
Set ClosedRange = TargetRange.SpecialCells(xlCellTypeVisible)
TargetRange.AutoFilter
ClosedRange.Copy
CopyToCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ClosedRange.ClearContents
Set ClosedRange=Nothing
Range("A2").Select
OrgSh.Protect DrawingObjects:=True, Contents:=True, _
   Scenarios:=True, AllowSorting:=True
End Sub

Regards,
Per

"Mel" <[email protected]> skrev i meddelelsen










- Show quoted text -
Click to expand...

Almost got it working.
Took what you gave me and added to it.
Works great when I have a row with a 'C' in column 'J', but if I don't
have any rows with a 'C', it copies
row A2 over to the Pension Closed Log. Is there any way I can not
copy anything if there is no
row with a C in column J? thx
Sub Sort_Status_And_Copy_Closed()


Dim OrgSh As Worksheet
Dim TargetSh As Worksheet
Dim TargetRange As Range
Dim ClosedRange As Range
Dim CopyToCell As Range


Set OrgSh = Worksheets("Pension Log")
Set TargetSh = Worksheets("Pension Closed Log")
Set TargetRange = OrgSh.Range("A2", OrgSh.Range("L" & Rows.Count).End
(xlDown))
Set CopyToCell = TargetSh.Range("A" & Rows.Count).End(xlUp).Offset(1,
0)

ActiveSheet.Unprotect
Range("A1:L5000").Select
Selection.Sort Key1:=Range("j2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True

OrgSh.Unprotect
TargetSh.Unprotect
TargetRange.Sort Key1:=Range("j2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
TargetRange.AutoFilter Field:=10, Criteria1:="C"
Set ClosedRange = TargetRange.SpecialCells(xlCellTypeVisible)
TargetRange.AutoFilter
ClosedRange.Copy
CopyToCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ClosedRange.ClearContents
Set ClosedRange = Nothing

Sheets("Pension Closed Log").Select
ActiveSheet.Unprotect
Range("A1:L5000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True


Sheets("Pension Log").Select
ActiveSheet.Unprotect
Range("A2:L5000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True
OrgSh.Protect
TargetSh.Protect


End Sub
 
P

Per Jessen

Hi

This should do it:

Sub Sort_Status_And_Copy_Closed()

Dim OrgSh As Worksheet
Dim TargetSh As Worksheet
Dim TargetRange As Range
Dim ClosedRange As Range
Dim CopyToCell As Range

Set OrgSh = Worksheets("Pension Log")
Set TargetSh = Worksheets("Pension Closed Log")
Set TargetRange = OrgSh.Range("A2", OrgSh.Range("L" &
Rows.Count).End(xlDown))
Set CopyToCell = TargetSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)

OrgSh.Unprotect
TargetSh.Unprotect
TargetRange.Sort Key1:=TargetSh.Range("j2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
TargetRange.AutoFilter Field:=10, Criteria1:="C"
Set ClosedRange = TargetRange.SpecialCells(xlCellTypeVisible)
If ClosedRange.Rows.Count > 1 Then
TargetRange.AutoFilter
ClosedRange.Copy
CopyToCell.PasteSpecial Paste:=xlPasteValues
CopyToCell.EntireRow.Delete 'Delete Heading row from pasted data
Application.CutCopyMode = False
ClosedRange.ClearContents
End If
Set ClosedRange = Nothing

TargetSh.Range("A1", Range("L" & Rows.Count).End(xlUp)).Sort _
Key1:=TargetSh.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
TargetSh.Range("A2").Select
TargetSh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True

OrgSh.Range("A2", Range("L" & Rows.Count).End(xlUp)).Sort _
Key1:=OrgSh.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
OrgSh.Range("A2").Select

OrgSh.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True
End Sub


Regards,
Per

"Mel" <[email protected]> skrev i meddelelsen
Hi

Try this (untested). Check sheet names and add code to unprotect TargetSh
if
required:

Sub Sort_Status_And_Copy_Closed()

'
Dim OrgSh As Worksheet
Dim TargetSh As Worksheet
Dim TargetRange As Range
Dim ClosedRange As Range
Dim CopyToCell As Range

Set OrgSh = Worksheets("Pension Log")
Set TargetSh = Worksheets("Pension Closed Log")
Set TargetRange = OrgSh.Range("A1", OrgSh.Range("L" &
Rows.Count).End(xlUp))
Set CopyToCell = TargetSh.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
OrgSh.Unprotect
TargetRange.Sort Key1:=Range("j2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
TargetRange.AutoFilter Field:=10, Criteria1:="C"
Set ClosedRange = TargetRange.SpecialCells(xlCellTypeVisible)
TargetRange.AutoFilter
ClosedRange.Copy
CopyToCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ClosedRange.ClearContents
Set ClosedRange=Nothing
Range("A2").Select
OrgSh.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowSorting:=True
End Sub

Regards,
Per

"Mel" <[email protected]> skrev i
meddelelsen










- Show quoted text -
Click to expand...

Almost got it working.
Took what you gave me and added to it.
Works great when I have a row with a 'C' in column 'J', but if I don't
have any rows with a 'C', it copies
row A2 over to the Pension Closed Log. Is there any way I can not
copy anything if there is no
row with a C in column J? thx
Sub Sort_Status_And_Copy_Closed()


Dim OrgSh As Worksheet
Dim TargetSh As Worksheet
Dim TargetRange As Range
Dim ClosedRange As Range
Dim CopyToCell As Range


Set OrgSh = Worksheets("Pension Log")
Set TargetSh = Worksheets("Pension Closed Log")
Set TargetRange = OrgSh.Range("A2", OrgSh.Range("L" & Rows.Count).End
(xlDown))
Set CopyToCell = TargetSh.Range("A" & Rows.Count).End(xlUp).Offset(1,
0)

ActiveSheet.Unprotect
Range("A1:L5000").Select
Selection.Sort Key1:=Range("j2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True

OrgSh.Unprotect
TargetSh.Unprotect
TargetRange.Sort Key1:=Range("j2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
TargetRange.AutoFilter Field:=10, Criteria1:="C"
Set ClosedRange = TargetRange.SpecialCells(xlCellTypeVisible)
TargetRange.AutoFilter
ClosedRange.Copy
CopyToCell.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ClosedRange.ClearContents
Set ClosedRange = Nothing

Sheets("Pension Closed Log").Select
ActiveSheet.Unprotect
Range("A1:L5000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True


Sheets("Pension Log").Select
ActiveSheet.Unprotect
Range("A2:L5000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A2").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowSorting:=True
OrgSh.Protect
TargetSh.Protect


End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Copy Entire Row based on Cell Value 4
move data from one spreadsheet to another and repeat 1
Copy Entire Row - Rick Rothstein ? 2
Macro that deletes and pastes filterd rows and then some 2
Copy data from Closed Workbook 3
need code to copy/move data between sheets 3
open excel file and copy data to another file 4
Copy worksheet from one workbook to another 3

Top