G
Guest
Guest
I am trying to constrict the use of this macro so that it will only run if cell A7 on a sheet called individual has been selected. The macro will be started by pressing CTRL I so I do not want it to run only if the cell is clicked on.
Any other comments on the macro that may stop things falling apart most welcome.
Sub new_Wb()
'
' new_Wb Macro
' Macro recorded 11/03/2002 by gj
'
'
'If Worksheets("Individual").Cells(7, 1) = ActiveCell Then
Worksheets.Copy
Sheets("Individual").Select
Set ToWS = Worksheets("Individual")
Set SRV = Worksheets("Settled RV")
Dim SheetName As String
With Worksheets("Listing")
For irow = 3 To .UsedRange.Row + .UsedRange.Rows.Count - 1
If Not .Cells(irow, 1) = .Cells(2, 1) Then
.Cells(irow, 1).Copy Destination:=ToWS.Cells(7, 1)
ToWS.Cells(7, 1).ShrinkToFit = False
PropertyName = ToWS.Cells(7, 1)
ToWS.Select
Cells.Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
If Len(PropertyName) > 31 Then
SheetName = Left(PropertyName, 22) & ".." & Right(PropertyName, 6)
Else
SheetName = Left(PropertyName, 31)
End If
For i = 1 To Len(SheetName)
strChr = Mid(SheetName, i, 1)
Select Case strChr
Case Chr(42), Chr(47), Chr(58), Chr(63), Chr(92)
strtemp = strtemp & "-"
Case Else
strtemp = strtemp & strChr
End Select
Next i
SheetName = strtemp
ActiveSheet.Name = SheetName
SheetName = " "
strtemp = " "
ActiveSheet.Cells(7, 1).Select
End If
Next irow
End With
Worksheets(Array("Info", "Totals", "Settled RV", "Individual")).Visible = xlHidden
Dim oSht As Object 'deletes all hidden sheets
Application.DisplayAlerts = False 'suppress delete warning
For Each oSht In Sheets
If Not oSht.Visible Then oSht.Delete
Next
Application.DisplayAlerts = True
'End If
End Sub
Any other comments on the macro that may stop things falling apart most welcome.
Sub new_Wb()
'
' new_Wb Macro
' Macro recorded 11/03/2002 by gj
'
'
'If Worksheets("Individual").Cells(7, 1) = ActiveCell Then
Worksheets.Copy
Sheets("Individual").Select
Set ToWS = Worksheets("Individual")
Set SRV = Worksheets("Settled RV")
Dim SheetName As String
With Worksheets("Listing")
For irow = 3 To .UsedRange.Row + .UsedRange.Rows.Count - 1
If Not .Cells(irow, 1) = .Cells(2, 1) Then
.Cells(irow, 1).Copy Destination:=ToWS.Cells(7, 1)
ToWS.Cells(7, 1).ShrinkToFit = False
PropertyName = ToWS.Cells(7, 1)
ToWS.Select
Cells.Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
If Len(PropertyName) > 31 Then
SheetName = Left(PropertyName, 22) & ".." & Right(PropertyName, 6)
Else
SheetName = Left(PropertyName, 31)
End If
For i = 1 To Len(SheetName)
strChr = Mid(SheetName, i, 1)
Select Case strChr
Case Chr(42), Chr(47), Chr(58), Chr(63), Chr(92)
strtemp = strtemp & "-"
Case Else
strtemp = strtemp & strChr
End Select
Next i
SheetName = strtemp
ActiveSheet.Name = SheetName
SheetName = " "
strtemp = " "
ActiveSheet.Cells(7, 1).Select
End If
Next irow
End With
Worksheets(Array("Info", "Totals", "Settled RV", "Individual")).Visible = xlHidden
Dim oSht As Object 'deletes all hidden sheets
Application.DisplayAlerts = False 'suppress delete warning
For Each oSht In Sheets
If Not oSht.Visible Then oSht.Delete
Next
Application.DisplayAlerts = True
'End If
End Sub