Previous Topic Next Topic

Create new sheet,rename and allow duplicates numbering them sequ

Closed
MRafik Posts 24 Registration date Wednesday January 9, 2013 Status Member Last seen November 25, 2013 - Apr 19, 2013 at 06:28 PM
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Apr 27, 2013 at 10:09 AM
I have a workbook with 3 worksheets.
1) MENU
2) Arrears Report
3) NEW ACC
and a button on the menu sheet with the following macro below

The problem I have is it allows duplicates with extension (0),
and the next is (0)(1) and the next is (0)(1)(2) but I want the
extensions to be (0), and the next to be (1) and the next to be (2) etc

Please note I am a novice in vba

All help will be appreciated. 

Public Function checksheet(PropertyAdd As String) As Boolean
    Dim found As Boolean
    Dim i As Integer
    found = False
    For i = 1 To Sheets.Count
        If Sheets(i).Name = PropertyAdd Then
            found = True
        End If
    Next i
    checksheet = found
End Function

Sub Button5_Click()
'
    Sheets("NEW ACC").Select
    Sheets("NEW ACC").Copy Before:=Sheets(3)
   
    Dim PropertyAdd As String
    Dim haveName As Boolean
    Dim extension As Integer
    
    haveName = False
    Do While (Not haveName)
        PropertyAdd = InputBox("Please type property address street name first (e.g. Berners St 123)", "Property Address", "Type property address")
If checksheet(PropertyAdd) Then
            extension = 0
            If MsgBox("That name is already in use. Do you want a duplicate name?", vbYesNo) Then
                Do While (Not haveName)
                    PropertyAdd = PropertyAdd & " (" & extension & ")"
                    If checksheet(PropertyAdd) Then
                        extension = extension + 1
                    Else
                        haveName = True
                    End If
                Loop
            End If
        Else
            haveName = True
        End If
    Loop

    Range("C2").Select
    ActiveCell.FormulaR1C1 = PropertyAdd

    
    Percentage = InputBox("Please type commission % for this property (in this format: x%)", "Commission Percentage", "10%")
    Range("y5").Select
    ActiveCell.FormulaR1C1 = Percentage
       
    Sheets("Arrears Report").Select
    Range("B7:L7").Select
    
    
    
    Selection.Insert Shift:=xlDown
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-5]C[1]"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-6]C[-2]"
    Range("D7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[0]"
    Range("E7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[10]"
    Range("F7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[1]"
    
    Range("G7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF('NEW ACC (2)'!R[-2]C[1]<0,'NEW ACC (2)'!R[-2]C[1],""NIL"")"
    Range("H7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[-1]"
    Range("I7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[-6]"
    Range("J7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[7]"
    Range("K7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-2]C[19]"
    Range("L7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[3]"
    Application.Run "Sortnewacc6"
    Sheets("NEW ACC (2)").Select
    ActiveSheet.Name = [C2]
    Range("C3").Select
    
    Dim again As Boolean
      Dim j As Integer
      Dim iAnswer As VbMsgBoxResult
      '
      ' Prompt the user as which direction they wish to
      ' sort the worksheets.
      '
      iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
            & "Clicking No will sort in Descending Order", _
            vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
      again = True
     Do While again
            again = False
            For j = 4 To Sheets.Count - 3
                  '
                  ' If the answer is Yes, then sort in ascending order.
                  '
                  If iAnswer = vbYes Then
                        If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
                              Sheets(j).Move After:=Sheets(j + 1)
                              again = True
                        End If
                        '
                        ' If the answer is No, then sort in descending order.
                        '
                  Else
                        If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
                              Sheets(j).Move After:=Sheets(j + 1)
                              again = True
                        End If
                  End If
            Next j
      Loop
End Sub

Sub Sortnewacc6()
'
' Sort Macro

'
Range("B6:L305").Select
    ActiveWorkbook.Worksheets("Arrears Report").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Arrears Report").Sort.SortFields.Add Key:=Range( _
        "B6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Arrears Report").Sort
        .SetRange Range("B6:L305")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

''Original code for sort
    'Range("B6:L300").Select
    'Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
        'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    'Range("B6").Select
End Sub
Related:

2 responses

Answer 1 / 2
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Apr 20, 2013 at 09:44 AM
try this these changes. 
Public Function checksheet(PropertyAdd As String) As Boolean
    Dim found As Boolean
    Dim i As Integer
    found = False
    For i = 1 To Sheets.Count
        If Sheets(i).Name = PropertyAdd Then
            found = True
        End If
    Next i
    checksheet = found
End Function

Sub Button5_Click()
'
    Sheets("NEW ACC").Select
    Sheets("NEW ACC").Copy Before:=Sheets(3)
   
    Dim PropertyAdd As String
    Dim haveName As Boolean
    Dim extension As Integer
    Dim temp      As String
    
    haveName = False
    Do While (Not haveName)
        PropertyAdd = InputBox("Please type property address street name first (e.g. Berners St 123)", "Property Address", "Type property address")
        If checksheet(PropertyAdd) Then
            If MsgBox("That name is already in use. Do you want a duplicate name?", vbYesNo) Then
                extension = 0
                Do While (Not haveName)
                    temp = PropertyAdd & " (" & extension & ")"
                    If checksheet(temp) Then
                        extension = extension + 1
                    Else
                        PropertyAdd = temp
                        haveName = True
                    End If
                Loop
            End If
        Else
            haveName = True
        End If
    Loop

    Range("C2").Select
    ActiveCell.FormulaR1C1 = PropertyAdd

    
    Percentage = InputBox("Please type commission % for this property (in this format: x%)", "Commission Percentage", "10%")
    Range("y5").Select
    ActiveCell.FormulaR1C1 = Percentage
       
    Sheets("Arrears Report").Select
    Range("B7:L7").Select
    
    
    
    Selection.Insert Shift:=xlDown
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-5]C[1]"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-6]C[-2]"
    Range("D7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[0]"
    Range("E7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[10]"
    Range("F7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[1]"
    
    Range("G7").Select
    ActiveCell.FormulaR1C1 = _
        "=IF('NEW ACC (2)'!R[-2]C[1]<0,'NEW ACC (2)'!R[-2]C[1],""NIL"")"
    Range("H7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[-1]"
    Range("I7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[-6]"
    Range("J7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[7]"
    Range("K7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-2]C[19]"
    Range("L7").Select
    ActiveCell.FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[3]"
    Application.Run "Sortnewacc6"
    Sheets("NEW ACC (2)").Select
    ActiveSheet.Name = [C2]
    Range("C3").Select
    
    Dim again As Boolean
      Dim j As Integer
      Dim iAnswer As VbMsgBoxResult
      '
      ' Prompt the user as which direction they wish to
      ' sort the worksheets.
      '
      iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
            & "Clicking No will sort in Descending Order", _
            vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
      again = True
     Do While again
            again = False
            For j = 4 To Sheets.Count - 3
                  '
                  ' If the answer is Yes, then sort in ascending order.
                  '
                  If iAnswer = vbYes Then
                        If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then
                              Sheets(j).Move After:=Sheets(j + 1)
                              again = True
                        End If
                        '
                        ' If the answer is No, then sort in descending order.
                        '
                  Else
                        If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then
                              Sheets(j).Move After:=Sheets(j + 1)
                              again = True
                        End If
                  End If
            Next j
      Loop
End Sub

Sub Sortnewacc6()
'
' Sort Macro

'
Range("B6:L305").Select
    ActiveWorkbook.Worksheets("Arrears Report").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Arrears Report").Sort.SortFields.Add Key:=Range( _
        "B6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Arrears Report").Sort
        .SetRange Range("B6:L305")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

''Original code for sort
    'Range("B6:L300").Select
    'Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
        'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    'Range("B6").Select
End Sub
Answer 2 / 2
MRafik Posts 24 Registration date Wednesday January 9, 2013 Status Member Last seen November 25, 2013
Apr 22, 2013 at 07:14 AM
Thank you very much Rizvisa1
It works perfectly.

Can i have some further help, would it be possible to
split the above macro into sub macros and how i would i
do it. As have been advised that the macro above is too
long.
rizvisa1 Posts 4478 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 766
Apr 27, 2013 at 10:09 AM
Answer is yes. You should break macro into smaller pieces. In most ideal world, you should not be too many things in one place. Other general idea is to see if you are in loop and what ever happens in a loop can be moved to a method. smaller methods are easy to maintain and easy to understand.

Here is one attempt on your existing macro. One thing, is that you should always have
Option Explicit
at the top. It forces you to declare variables and would lead to less issues
Other thing is that, you should not select sheets or cell to do some thing to it, unless you really have to. It slows down the performance. 
Option Explicit 

Public Function checksheet(PropertyAdd As String) As Boolean 
Dim found As Boolean 
Dim i As Integer 

   found = False 
   For i = 1 To Sheets.Count 
      If Sheets(i).Name = PropertyAdd Then 
         found = True 
         Exit For ' now that you found it, quit loop 
      End If 
   Next i 
   checksheet = found 
End Function 
    
Private Function buildNewSheetName() As String 
Dim haveName      As Boolean 
Dim PropertyAdd   As String 
Dim temp          As String 
Dim extension     As Integer 

   haveName = False 
   Do 
      PropertyAdd = InputBox("Please type property address street name first (e.g. Berners St 123)", "Property Address", "Type property address") 
      If checksheet(PropertyAdd) Then 
         If MsgBox("That name is already in use. Do you want a duplicate name?", vbYesNo) Then 
            extension = 0 
            Do While (Not haveName) 
               temp = PropertyAdd & " (" & extension & ")" 
               If checksheet(temp) Then 
                  extension = extension + 1 
               Else 
                  PropertyAdd = temp 
                  haveName = True 
               End If 
            Loop 
         End If 
      Else 
         haveName = True 
      End If 
   Loop Until (Not haveName) 
   buildNewSheetName = PropertyAdd 
End Function 

Private Sub updateArrearsReport() 
   Sheets("Arrears Report").Select 
   Range("B7:L7").Insert Shift:=xlDown 
   Range("B7").FormulaR1C1 = "='NEW ACC (2)'!R[-5]C[1]" 
   Range("C7").FormulaR1C1 = "='NEW ACC (2)'!R[-6]C[-2]" 
   Range("D7").FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[0]" 
   Range("E7").FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[10]" 
   Range("F7").FormulaR1C1 = "='NEW ACC (2)'!R[-3]C[1]" 
    
   Range("G7").FormulaR1C1 = "=IF('NEW ACC (2)'!R[-2]C[1]<0,'NEW ACC (2)'!R[-2]C[1],""NIL"")" 
   Range("H7").FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[-1]" 
   Range("I7").FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[-6]" 
   Range("J7").FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[7]" 
   Range("K7").FormulaR1C1 = "='NEW ACC (2)'!R[-2]C[19]" 
   Range("L7").FormulaR1C1 = "='NEW ACC (2)'!R[-4]C[3]" 
End Sub 

Private Sub performSortAgain() 
Dim again As Boolean 
Dim j As Integer 
Dim iAnswer As VbMsgBoxResult 
    
   ' 
   ' Prompt the user as which direction they wish to 
   ' sort the worksheets. 
   ' 
   iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _ 
                     & "Clicking No will sort in Descending Order", _ 
                     vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets") 
   again = True 
   Do While again 
      again = False 
      For j = 4 To Sheets.Count - 3 
         ' 
         ' If the answer is Yes, then sort in ascending order. 
         ' 
         If iAnswer = vbYes Then 
            If UCase$(Sheets(j).Name) > UCase$(Sheets(j + 1).Name) Then 
               Sheets(j).Move After:=Sheets(j + 1) 
               again = True 
            End If 
            ' 
         ' If the answer is No, then sort in descending order. 
         ' 
         Else 
            If UCase$(Sheets(j).Name) < UCase$(Sheets(j + 1).Name) Then 
               Sheets(j).Move After:=Sheets(j + 1) 
               again = True 
            End If 
         End If 
      Next j 
   Loop 
End Sub 

Sub Button5_Click() 
   Dim PropertyAdd As String 
   Dim Percentage As String 
    
   Sheets("NEW ACC").Select 
   Sheets("NEW ACC").Copy Before:=Sheets(3) 
    
   PropertyAdd = buildNewSheetName() 
   Range("C2").FormulaR1C1 = PropertyAdd 
   Percentage = InputBox("Please type commission % for this property (in this format: x%)", "Commission Percentage", "10%") 
   Range("y5").FormulaR1C1 = Percentage 
    
   Call updateArrearsReport 
   Application.Run "Sortnewacc6" 
    
   Sheets("NEW ACC (2)").Select 
   ActiveSheet.Name = [C2] 
   Range("C3").Select 
   Call performSortAgain 
    
End Sub 
    
Sub Sortnewacc6()
   '
   ' Sort Macro
   
   '
   Range("B6:L305").Select
   ActiveWorkbook.Worksheets("Arrears Report").Sort.SortFields.Clear
   ActiveWorkbook.Worksheets("Arrears Report").Sort.SortFields.Add _
      Key:=Range("B6"), _
      SortOn:=xlSortOnValues, _
      Order:=xlAscending, _
      DataOption:=xlSortNormal
      
   With ActiveWorkbook.Worksheets("Arrears Report").Sort
      .SetRange Range("B6:L305")
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
   End With
   
   ''Original code for sort
   'Range("B6:L300").Select
   'Selection.Sort Key1:=Range("B6"), Order1:=xlAscending, Header:=xlGuess, _
   'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   'Range("B6").Select
End Sub

Similar discussions

Can you rename the inputs on LG Smart TV (WebOS)?
sjdunning -
dhh1 -

4 responses