cut & paste assistance needed

[tlm2740]

I would appreciate any assistance/guidance given on this subject, I have been trying to solve this for 2 days now and have not been successful.

I have a worksheet containing information (Physician protocols) that I would like to copy (or move) cells from columns B:E to a new worksheet based on the value in column A. I would also like to use the value in column A as the name of the new worksheet. This needs to run only once on a list of 552.

I attached a small portion of the workbook which includes 3 worksheets, the first being the protocols themselves and then 2 examples of what I am trying to do.

Thank you in advance,

Tim

[geekgirlau]

Okay, much of what you're after can be recorded.

First, you need a range name for your data. Personally I would use a dynamic range so it doesn't matter how many rows you have, like the following:


=OFFSET(Protocols!$A$1,0,0,COUNTA(Protocols!$A:$A),5)

Now record a macro that uses the autofilter to show all rows where the value of "Outline" is "(formulary) Insulins". Copy the range, insert a new worksheet and paste the range. Then rename the new sheet as "(formulary) Insulins" - you'll need your macro to check to see if that sheet already exists, and if so delete the sheet. Then do the same thing with "(Future) Elective cardioversion".

This will probably get you started - try recording this much and we'll take it from there.

[johnske]

I would appreciate any assistance/guidance given on this subject, I have been trying to solve this for 2 days now and have not been successful.

I have a worksheet containing information (Physician protocols) that I would like to copy (or move) cells from columns B:E to a new worksheet based on the value in column A. I would also like to use the value in column A as the name of the new worksheet. This needs to run only once on a list of 552.

I attached a small portion of the workbook which includes 3 worksheets, the first being the protocols themselves and then 2 examples of what I am trying to do.

Thank you in advance,

TimHi Tim,

Try this (I'm assuming here that with a list of 552 you'll also need a table of contents to navigate thru the workbook)


Option Explicit

Sub CopyProtocols()
Dim SheetName As String, N As Long, HasSameName As Long
With Sheets("Protocols")
Application.ScreenUpdating = False
N = 2
Do
SheetName = .Range("A" & N)
HasSameName = WorksheetFunction .CountIf(.Range("A2", _
.Range("A" & Cells.Rows.Count) .End(xlUp)), SheetName)
Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = SheetName
ActiveSheet.Range("A1") = SheetName
.Range("B" & N & ":E" & (N + HasSameName)) _
.Copy ActiveSheet.Range("A3")
Columns.AutoFit
N = N + HasSameName
Loop Until .Range("A" & N) = Empty
End With
Application.ScreenUpdating = True
'add a table of contents
TableOfContents
End Sub

Private Sub TableOfContents()
Dim Sheet As Worksheet, N As Long
Application.ScreenUpdating = False
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Table Of Contents"
ActiveWindow.DisplayGridlines = False
Range("A1") = "Contents"
For N = 2 To Sheets.Count
With Sheets(N)
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", SubAddress:= _
"'Table Of Contents'!A1", TextToDisplay:=Sheets(N).Name
End With
With Worksheets("Table Of Contents")
.Hyperlinks.Add anchor:=.Range("A" & N), Address:="", SubAddress:= _
"'" & Sheets(N).Name & "'!A1", TextToDisplay:=Sheets(N).Name
.Columns.AutoFit
End With
Next
Application.ScreenUpdating = True
End Sub
EDIT: Tim, I discovered an error after posting, the code above and the code in the attachment have since been altered to correct the error.

[tlm2740]

thank you both for responding and looking at this this.

johnske, I tried your code and it gets an error on 2 things, illegal characters ": / [ ]" and name lengths longer than 31.

is there a work around for these?

[johnske]

thank you both for responding and looking at this this.

johnske, I tried your code and it gets an error on 2 things, illegal characters ": / [ ]" and name lengths longer than 31.

is there a work around for these?Hi Tim,

No, I don't know of a way around this (that's not saying there isn't one).

The modified code below prohibits sheet names longer than 31 characters but still gives the full-name in A1 on the relevant sheet and in the index sheet. At the moment it will still error out on illegal characters.

But consider this: If you have both a hyperlinked index and sheet-heading with the full unrestricted text, does the sheet-name then really have to be identical to this? i.e. can't the sheet-names either then be just Sheet1, Sheet2, Sheet3,.... etc? OR, an abridged sheet-name that has the illegal characters removed (perhaps replaced with others such as ; | ( ) )? Either of these is do-able, let me know...


Option Explicit
Sub CopyProtocols()
Dim N As Long, HasSameName As Long
With Sheets("Protocols")
Application.ScreenUpdating = False
N = 2
Do
HasSameName = WorksheetFunction _
.CountIf(.Range("A2", _
.Range("A" & Cells.Rows.Count) _
.End(xlUp)), .Range("A" & N))
Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Range("A1") = .Range("A" & N)
ActiveSheet.Name = Left(.Range("A" & N), 31)
.Range("B" & N & ":E" & (N + HasSameName - 1)) _
.Copy ActiveSheet.Range("A3")
Columns.AutoFit
N = N + HasSameName
Loop Until .Range("A" & N) = Empty
End With
Application.ScreenUpdating = True
'add a table of contents
TableOfContents
End Sub

Private Sub TableOfContents()
Dim Sheet As Worksheet, N As Long
Application.ScreenUpdating = False
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Table Of Contents"
ActiveWindow.DisplayGridlines = False
Range("A1") = "Contents"
For N = 2 To Sheets.Count
With Sheets(N)
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", SubAddress:= _
"'Table Of Contents'!A1", TextToDisplay:=Sheets(N).Range("A1").Value
End With
With Worksheets("Table Of Contents")
.Hyperlinks.Add anchor:=.Range("A" & N), Address:="", SubAddress:= _
"'" & Sheets(N).Name & "'!A1", TextToDisplay:=Sheets(N).Range("A1").Value
.Columns.AutoFit
End With
Next
Application.ScreenUpdating = True
End Sub

[tlm2740]

thank you very much for the assistance with this...

you're right about the tab names, since there will be a navigation page I can just use a simple sheet1, sheet2... etc, this is a good thing because some of the names do not look right chopped up.

do you mind if I ask something else on this same workbook, if I was to make a template worksheet where the name would always go into cell "B3" and the other rows start at "A11" would this be the code correction?


Sheets("Template").Copy After:=Worksheets(Worksheets.Count)
ActiveSheet.Range("B3") = .Range("A" & N)
ActiveSheet.Name = Left(.Range("A" & N), 31)
.Range("B" & N & ":E" & (N + HasSameName - 1)) _
.Copy ActiveSheet.Range("A11)


I tried to do this earlier today because I was asked to put some static information on each worksheet (copyright and contact information) but when I ran it I would get a "1004" error, I think it has to do with a bug in MSExcel and the fact I am making 552 copies, thier website said this occurs when their is not enough memory to run a job. They recommend doing a save after every 100 copies.

Once again thanks for all the help and I am going to mark this as solved.

[johnske]

Hi Tim,

Yes, that's the correct addressing for that particular mod. But use Range("A11") not Range("A11) as the latter will give an error

Here's the code to give just Sheet1, Sheet2, etc. as sheet-names. I've added a CutCopyMode = False to clear the clipboard and (maybe) get around any memory limitation, but it shouldn't have any affect as this method of copy/paste doesn't use the clipboard - it won't hurt to leave it in though.


Option Explicit

Sub CopyProtocols()
Dim N As Long, HasSameName As Long
With Sheets("Protocols")
Application.ScreenUpdating = False
N = 2
Do
HasSameName = WorksheetFunction .CountIf(.Range("A2", _
.Range("A" & Cells.Rows.Count) .End(xlUp)), .Range("A" & N))
Sheets.Add after:=Worksheets(Worksheets.Count)
Range("A1") = .Range("A" & N)
.Range("B" & N & ":E" & (N + HasSameName - 1)) _
.Copy ActiveSheet.Range("A3")
Application.CutCopyMode = False
Columns.AutoFit
N = N + HasSameName
Loop Until .Range("A" & N) = Empty
End With
Application.ScreenUpdating = True
'add a table of contents
TableOfContents
End Sub

Private Sub TableOfContents()
Dim Sheet As Worksheet, N As Long
Application.ScreenUpdating = False
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Table Of Contents"
ActiveWindow.DisplayGridlines = False
[A1] = "Table of Contents"
For N = 2 To Sheets.Count
With Sheets(N)
.Hyperlinks.Add anchor:=.[A1], Address:="", SubAddress:= _
"'Table Of Contents'!A1", TextToDisplay:=Sheets(N).[A1].Value
End With
With Worksheets("Table Of Contents")
.Hyperlinks.Add anchor:=.Range("A" & N), Address:="", SubAddress:= _
"'" & Sheets(N).Name & "'!A1", TextToDisplay:=Sheets(N).[A1].Value
.Columns.AutoFit
End With
Next
Application.ScreenUpdating = True
End Sub


Regards,
John