Macro not working correctly

Hello all,

I have written a macro that looks at one column of text and depending on what
is in the cell of that column, the macro would copy a template worksheet. The
macro works for the first cell in the column but then it defaulted back to
the last condition. I cannot get it to work correctly and hoping you guys can
give me some pointers. Below is the code for the macro...I appreciate the
help. Thanks.

Sub Test1()
Dim x As Integer
' Set numrows = number of rows of data.
NumRows = Range("B60", Range("B60").End(xlDown)).Rows.Count
' Select cell B601.
Range("B60").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows - 1
If Range("C60").Value = "A" Then
Sheets("Template A").Copy Befo=Sheets("End")
Sheets("Template A (2)").Name = "A" & Format(x, "000")
ElseIf Range("C60").Value = "B" Then
Sheets("Template B").Copy Befo=Sheets("End")
Sheets("Template B (2)").Name = "B" & Format(x, "000")
ElseIf Range("C60").Value = "C" Then
Sheets("Template C").Copy Befo=Sheets("End")
Sheets("Template C(2)").Name = "C" & Format(x, "000")
ElseIf Range("C60").Value = "Detail" Then
Sheets("Template D").Copy Befo=Sheets("End")
Sheets("Template D (2)").Name = "D" & Format(x, "000")
ElseIf Range("C60").Value = "" Then
Sheets("Template E").Copy Befo=Sheets("End")
Sheets("Template E (2)").Name = "E" & Format(x, "000")
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub

--
Message posted via http://www.officekb.com

Hi

Your macro is comparing af fixed cell in the loop (C60), use a variable to
hold the cell to compare. Also I would use a Case Select structure rather
than IF..Then...Else

Give this a try:

Sub Test1()
Dim x As Integer
Dim Criterium As Range
' Set numrows = number of rows of data.
NumRows = Range("B60", Range("B60").End(xlDown)).Rows.Count
Set Criterium = Range("C60")
' Select cell B601.
'Range("B60").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows - 1
Select Case Criterium
Case Is = "A"
Sheets("Template A").Copy Befo=Sheets("End")
Sheets("Template A (2)").Name = "A" & Format(x, "000")
Case Is = "B"
Sheets("Template B").Copy Befo=Sheets("End")
Sheets("Template B (2)").Name = "B" & Format(x, "000")
Case Is = "C"
Sheets("Template C").Copy Befo=Sheets("End")
Sheets("Template C(2)").Name = "C" & Format(x, "000")
Case Is = "Detail"
Sheets("Template D").Copy Befo=Sheets("End")
Sheets("Template D (2)").Name = "D" & Format(x, "000")
Case Is = ""
Sheets("Template E").Copy Befo=Sheets("End")
Sheets("Template E (2)").Name = "E" & Format(x, "000")
End Select
Set Criterium = Criterium.Offset(1, 0)
Next
End Sub

Regards,
Per

"Andy_N1708 via OfficeKB.com" u40722@uwe skrev i meddelelsen
news:a88d0cde22da3@uwe...
Hello all,

I have written a macro that looks at one column of text and depending on
what
is in the cell of that column, the macro would copy a template worksheet.
The
macro works for the first cell in the column but then it defaulted back to
the last condition. I cannot get it to work correctly and hoping you guys
can
give me some pointers. Below is the code for the macro...I appreciate the
help. Thanks.

Sub Test1()
Dim x As Integer
' Set numrows = number of rows of data.
NumRows = Range("B60", Range("B60").End(xlDown)).Rows.Count
' Select cell B601.
Range("B60").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows - 1
If Range("C60").Value = "A" Then
Sheets("Template A").Copy Befo=Sheets("End")
Sheets("Template A (2)").Name = "A" & Format(x, "000")
ElseIf Range("C60").Value = "B" Then
Sheets("Template B").Copy Befo=Sheets("End")
Sheets("Template B (2)").Name = "B" & Format(x, "000")
ElseIf Range("C60").Value = "C" Then
Sheets("Template C").Copy Befo=Sheets("End")
Sheets("Template C(2)").Name = "C" & Format(x, "000")
ElseIf Range("C60").Value = "Detail" Then
Sheets("Template D").Copy Befo=Sheets("End")
Sheets("Template D (2)").Name = "D" & Format(x, "000")
ElseIf Range("C60").Value = "" Then
Sheets("Template E").Copy Befo=Sheets("End")
Sheets("Template E (2)").Name = "E" & Format(x, "000")
ActiveCell.Offset(1, 0).Select
End If
Next
End Sub

--
Message posted via http://www.officekb.com

Hi Per,
Your code worked well. Thank you. However, using this method, I will be hard
coding the conditions, and that might not go well if people suddenly changed
the template names. So I need to make some improvements on this macro.

Per Jessen wrote:
Hi

Your macro is comparing af fixed cell in the loop (C60), use a variable to
hold the cell to compare. Also I would use a Case Select structure rather
than IF..Then...Else

Give this a try:

Sub Test1()
Dim x As Integer
Dim Criterium As Range
' Set numrows = number of rows of data.
NumRows = Range("B60", Range("B60").End(xlDown)).Rows.Count
Set Criterium = Range("C60")
' Select cell B601.
'Range("B60").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows - 1
Select Case Criterium
Case Is = "A"
Sheets("Template A").Copy Befo=Sheets("End")
Sheets("Template A (2)").Name = "A" & Format(x, "000")
Case Is = "B"
Sheets("Template B").Copy Befo=Sheets("End")
Sheets("Template B (2)").Name = "B" & Format(x, "000")
Case Is = "C"
Sheets("Template C").Copy Befo=Sheets("End")
Sheets("Template C(2)").Name = "C" & Format(x, "000")
Case Is = "Detail"
Sheets("Template D").Copy Befo=Sheets("End")
Sheets("Template D (2)").Name = "D" & Format(x, "000")
Case Is = ""
Sheets("Template E").Copy Befo=Sheets("End")
Sheets("Template E (2)").Name = "E" & Format(x, "000")
End Select
Set Criterium = Criterium.Offset(1, 0)
Next
End Sub

Regards,
Per

Hello all,

[quoted text clipped - 35 lines]
Next
End Sub

--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...excel/201005/1

Hi Andy,

Thanks for your reply.

A few things you can do to prevent people from changing template
names.

If user do not need to see the template sheets, you can just hide the
sheets. Set the Visible property of the worksheets to VeryHidden, then
sheets can only be made visible by code, but you can still copy them.

Another option is to protect the workbook for structure, then user can
not change any sheet names nor can he add or delete sheets. If you
choose this method, your code has to unprotect the workbook, before it
copies and rename the sheet(s).

Sub Test1()
Dim pWord as String

pWord="JustMe"' change to suit
ThisWorkbook.Unprotect Password:=pWord

'Your curretnt code

ThisWorkbook.Protect Password:= pWord
End Sub

Hopes this helps
....
Per

On 27 Maj, 02:39, "Andy_N1708 via OfficeKB.com" u40722@uwe wrote:
Hi Per,
Your code worked well. *Thank you. However, using this method, I will be hard
coding the conditions, and that might not go well if people suddenly changed
the template names. So I need to make some improvements on this macro.





Per Jessen wrote:
Hi

Your macro is comparing af fixed cell in the loop (C60), use a variable to
hold the cell to compare. Also I would use a Case Select structure rather
than IF..Then...Else

Give this a try:

Sub Test1()
Dim x As Integer
Dim Criterium As Range
' Set numrows = number of rows of data.
NumRows = Range("B60", Range("B60").End(xlDown)).Rows.Count
Set Criterium = Range("C60")
' Select cell B601.
'Range("B60").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows - 1
* *Select Case Criterium
* *Case Is = "A"
* * * *Sheets("Template A").Copy Befo=Sheets("End")
* * * *Sheets("Template A (2)").Name = "A" & Format(x, "000")
* *Case Is = "B"
* * * *Sheets("Template B").Copy Befo=Sheets("End")
* * * *Sheets("Template B (2)").Name = "B" & Format(x, "000")
* *Case Is = "C"
* * * *Sheets("Template C").Copy Befo=Sheets("End")
* * * *Sheets("Template C(2)").Name = "C" & Format(x, "000")
* *Case Is = "Detail"
* * * *Sheets("Template D").Copy Befo=Sheets("End")
* * * *Sheets("Template D (2)").Name = "D" & Format(x, "000")
* *Case Is = ""
* * * *Sheets("Template E").Copy Befo=Sheets("End")
* * * *Sheets("Template E (2)").Name = "E" & Format(x, "000")
* *End Select
* *Set Criterium = Criterium.Offset(1, 0)
Next
End Sub

Regards,
Per

Hello all,

[quoted text clipped - 35 lines]
* * *Next
* End Sub

--
Message posted via OfficeKB.comhttp://www.officekb.com/Uwe/Forums.aspx/ms-excel/201005/1- Skjul tekst i anførselstegn -

- Vis tekst i anførselstegn -