SaveAs Then CopyDown Then Sort

[JohnnyBravo]

I have an excel sheet where I'm trying to automate a 2-stop process. Here's the macro for the 1st part:


Sub UnprotectSaveAs_Adult()
' Unprotect_SaveAs Macro
' Macro recorded 11/23/2005 by John
ActiveSheet.Unprotect Password:="xxxxxxxxxx"
ChDir "C:\bmtdata"
ActiveWorkbook.SaveAs Filename:="adult.xls"
Application.DisplayAlerts = False
Range("P2").Activate
End Sub

Sub UnprotectSaveAs_Peds()
' Unprotect_SaveAs Macro
' Macro recorded 11/23/2005 by John
ActiveSheet.Unprotect Password:="xxxxxxxxxx"
ChDir "C:\bmtdata"
ActiveWorkbook.SaveAs Filename:="peds.xls"
Application.DisplayAlerts = False
Range("P2").Activate
End Sub

The 2nd part is thus:

The data entry operator will manually enter in a specific value (number) into Cell P2. I need VBA to take whatever number is entered in that cell and paste that into the rest of the column as long as there's a name or number entered in column A.

There's two sheets in this workbook that I'm dealing with but for my posting purposes it really doesn't matter. For this column P, I want VBA to look at the name of the worksheet and if it's got the word "Peds" or "pediatric" anywhere in the worksheet name, I want VBA to precede the number with 1000.

In another words, column P will look like this:

If it's Adult, it will be
412
412
412
412
412
412
etc.

If it's Peds, it will be:
1000412
1000412
1000412
1000412
1000412
1000412
etc.

It will not always be 412 - thats just my example. Then I want to sort by Column Heading "Patient ID"; and then by Column heading "Date of Transplant".

Thanks for your help.

[Rembo]

Hello Johnny,

In principle the code you need would look something like this:


Sub NumbersInColumnP()
Dim ws As Worksheet
Dim rCell As Range
Dim l As Long
For Each ws In Worksheets
With ws
If InStr(1, ws.Name, "Peds", vbTextCompare) > 0 Or _
InStr(1, ws.Name, "pediatric", vbTextCompare) > 0 Then
For Each rCell In .Range("A2:A" & .Range("A65536").End(xlUp).Row)
If rCell.Value <> "" Then
rCell.Offset(0, 15).Value = CLng("1000" & .Range("P1").Value)
End If
Next rCell
Else
For Each rCell In .Range("A2:A" & .Range("A65536").End(xlUp).Row)
If rCell.Value <> "" Then
rCell.Offset(0, 15).Value = CLng(.Range("P1").Value)
End If
Next rCell
End If
End With
Next ws
End Sub

As for the sorting part, just record a macro with the macro editor while doing the sorting manually. You can then automatically start your sorting routine by simply by adding the name of the sorting routine (macro) in the line right above 'End Sub'.

For example, if you recorded a sorting macro that's called 'Sortit' then the last three lines of the code above would become:


Next ws
Sortit
End Sub

Hope this will be enough to get you started.

Rembo

[JohnnyBravo]

Hello Johnny,

In principle the code you need would look something like this:


Sub NumbersInColumnP()
.....

For Each rCell In .Range("A2:A" & .Range("A65536").End(xlUp).Row)
If rCell.Value <> "" Then
rCell.Offset(0, 15).Value = CLng(.Range("P1").Value)
End If
Next rCell
End If
End With
Next ws
End Sub

Hope this will be enough to get you started.

Rembo

Rembo, thank you for your code. I tried to run it and it gave me a VBA editor error message at the highlighted line. :dunno

[mdmackillop]

I see that the code refers to P1, whilst your text refers to P2. Try correcting this.
Regards
MD

[JohnnyBravo]

MD, thank you for pointing that out. I am on a much needed weekend break now but when i return to work on Monday morning - I shall give it a try.

[geekgirlau]

Just one other thing to look at. Your "Unprotect" macros are both identical apart from the filename. You could replace it with this:



Sub UnprotectSaveAs(strFilename as String)
If strFilename <> "" Then
ActiveSheet.Unprotect Password:="xxxxxxxxxx"
ChDir "C:\bmtdata"
ActiveWorkbook.SaveAs Filename:=strFilename & ".xls"
Application.DisplayAlerts = False
Range("P2").Activate
End If
End Sub


To call the macro, you pass the name of the workbook


UnprotectSaveAs "adult"

[Rembo]

Rembo, thank you for your code. I tried to run it and it gave me a VBA editor error message at the highlighted line. :dunno

mdmackillop is right, I need to substitute cell P2 for P1. Also, which version of Excel are you using? I think Excel 97 would generate an error if there isn't a value in cell P2. I adjusted the routine to check for a value first.

And finally, I assumed you were going to use numeric values in cell P2. If you would enter text instead the code would return an error. In those cases it should be pretty obvious from the error you are receiving. (btw, what error did you get?) If that is your problem remove the CLng(..) function. This function converts a string (text) to a numeric value if the string consists of numeric characters.

While I was at it I added Application.ScreenUpdating = False/True. If you have large worksheets this will speed up the execution of the routine because it temporarily shuts of the display updating.

Rembo


Sub NumbersInColumnP()
Dim ws As Worksheet
Dim rCell As Range
Dim l As Long
Application.ScreenUpdating = False
For Each ws In Worksheets
With ws
If .Range("P2").Value <> "" Then
If InStr(1, ws.Name, "Peds", vbTextCompare) > 0 Or _
InStr(1, ws.Name, "pediatric", vbTextCompare) > 0 Then
For Each rCell In .Range("A3:A" & .Range("A65536").End(xlUp).Row)
If rCell.Value <> "" Then
rCell.Offset(0, 15).Value = CLng("1000" & .Range("P2").Value)
End If
Next rCell
Else
For Each rCell In .Range("A3:A" & .Range("A65536").End(xlUp).Row)
If rCell.Value <> "" Then
rCell.Offset(0, 15).Value = CLng(.Range("P2").Value)
End If
Next rCell
End If
End If
End With
Next ws
Application.ScreenUpdating = True
End Sub

[JohnnyBravo]

Just one other thing to look at. Your "Unprotect" macros are both identical apart from the filename. You could replace it with this:


Thanks Geekgirlau - are you saying that the vba code you provided above will save the file as "adult" or "peds" depending on the name of the worksheet?

Rembo - the value in Column P will always be numeric. Thanks again for your help. :)

[JohnnyBravo]

When I run the save as macro it keeps asking me whether I want to replace the existing file or not. As shown in my original posting above, I've got the line Application.DisplayAlerts = False ; but I have no idea how to make it stop asking me this question everytime.

I'm using Excel 2002 (SP 3)

[Rembo]

When I run the save as macro it keeps asking me whether I want to replace the existing file or not.

What you want to do is turn display alerts off before you save your workbook and turn display alerts back on again after saving.

Try replacing:


ActiveWorkbook.SaveAs Filename:="adult.xls"
Application.DisplayAlerts = False

With:


Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:="adult.xls"
Application.DisplayAlerts = True

As an alternative, if you were to close your workbook after saving you can also use something like the following:


ActiveWorkbook.Close SaveChanges:=True

Hope this helps,

Rembo

[JohnnyBravo]

You guys rock! Thanks Rembo. :)

[geekgirlau]

Don't forget to mark the thread as "Solved" using the Thread Tools.