Help me with this please!

Z

Zahhhaaaa

Board Regular
Joined
Jun 29, 2011
Messages
62
Ok, once again I'm creating this diary, I'm almost finished it but there's still some little things needs to be done.

Could you give me an advice how to add this code;

Code: 
Sub NewSheet()
Sheets("Default").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(Date, "dd.mm.yyyy")
End Sub

Into this code;

Code: 
Sub NewSheet()
Dim CurrentDay As Integer, NewName As String
If IsNumeric(Right(ActiveSheet.Name, 2)) Then
   CurrentDay = Right(ActiveSheet.Name, 2)
ElseIf IsNumeric(Right(ActiveSheet.Name, 1)) Then
   CurrentDay = Right(ActiveSheet.Name, 1)
Else
   Exit Sub
End If
CurrentDay = CurrentDay + 1
NewName = Format(Date, "dd.mm.yyyy")
Dim checkWs As Worksheet
On Error Resume Next
Set checkWs = Worksheets(NewName)
If checkWs Is Nothing Then
   Worksheets(ActiveSheet.Name).Copy After:=Worksheets(ActiveSheet.Index)
  Dim oleObj As OLEObject
With ActiveSheet
   .Name = NewName
   .Range("D2").ClearContents
   .Range("D6").ClearContents
   .Range("A31").ClearContents
   .Range("B31").ClearContents
   .Range("C31").ClearContents
   .Range("D31").ClearContents
   .Range("A34:B37").ClearContents
   .Range("C34:D37").ClearContents
   .Range("A40:B43").ClearContents
   .Range("C40:D43").ClearContents
   .Range("A46").ClearContents
   .Range("B46").ClearContents
   .Range("C46").ClearContents
   .Range("D46").ClearContents
   For Each oleObj In ActiveSheet.OLEObjects
      If oleObj.progID = "Forms.TextBox.1" Then oleObj.Object.Value = ""
   Next oleObj
   Dim Shp As Shape
 For Each Shp In ActiveSheet.Shapes
   If Shp.Type = msoTextBox Then
     Shp.TextFrame.Characters.Text = ""
   End If
 Next Shp
End With
 
Else
   Set checkWs = Nothing
   MsgBox "Uusi taulukko voidaan lisätä huomenna."
End If
End Sub

so that it resets sheet into "default-mode" and also clears all cells as seen above in code.

Both of these codes work fine, but I need to put them together. I tried to do it by myself but it didn't work :P
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Sort by date Sort by votes
try this:

Code: 
Sub NewSheet()
    Dim CurrentDay As Integer, NewName As String
    
    Sheets.Add
    ActiveSheet.Move After:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Format(Date, "dd.mm.yyyy")
    
    If IsNumeric(Right(ActiveSheet.Name, 2)) Then
       CurrentDay = Right(ActiveSheet.Name, 2)
    ElseIf IsNumeric(Right(ActiveSheet.Name, 1)) Then
       CurrentDay = Right(ActiveSheet.Name, 1)
    Else
       Exit Sub
    End If
    
    CurrentDay = CurrentDay + 1
    NewName = Format(Date, "dd.mm.yyyy")
    
    Dim checkWs As Worksheet
    
    On Error Resume Next
    
    Set checkWs = Worksheets(NewName)
    
    If checkWs Is Nothing Then
        Worksheets(ActiveSheet.Name).Copy After:=Worksheets(ActiveSheet.Index)
        Dim oleObj As OLEObject
        With ActiveSheet
           .Name = NewName
           .Range("D2").ClearContents
           .Range("D6").ClearContents
           .Range("A31").ClearContents
           .Range("B31").ClearContents
           .Range("C31").ClearContents
           .Range("D31").ClearContents
           .Range("A34:B37").ClearContents
           .Range("C34:D37").ClearContents
           .Range("A40:B43").ClearContents
           .Range("C40:D43").ClearContents
           .Range("A46").ClearContents
           .Range("B46").ClearContents
           .Range("C46").ClearContents
           .Range("D46").ClearContents
            For Each oleObj In ActiveSheet.OLEObjects
                If oleObj.progID = "Forms.TextBox.1" Then oleObj.Object.Value = ""
            Next oleObj
            Dim Shp As Shape
            For Each Shp In ActiveSheet.Shapes
                If Shp.Type = msoTextBox Then
                    Shp.TextFrame.Characters.Text = ""
                End If
            Next Shp
        End With
    Else
       Set checkWs = Nothing
       MsgBox "Uusi taulukko voidaan lisätä huomenna."
    End If
    
End Sub
 
Upvote 0
Try:
Code: 
Sub UusiSivu()
Dim CurrentDay As Integer
Dim NewName As String
Dim WS As Worksheet
Set WS = ActiveSheet
If IsNumeric(Right(WS.Name, 2)) Then
   CurrentDay = Right(WS.Name, 2)
ElseIf IsNumeric(Right(WS.Name, 1)) Then
   CurrentDay = Right(WS.Name, 1)
Else
   Exit Sub
End If

CurrentDay = CurrentDay + 1
NewName = Format(Date, "dd.mm.yyyy")
Dim checkWs As Worksheet
On Error Resume Next
Set checkWs = Worksheets(NewName)
If checkWs Is Nothing Then
'Copies the current sheet to the end of the workbook
   WS.Copy after:=Worksheets(Sheets.Count)
    ActiveSheet.Name = NewName
  Dim oleObj As OLEObject
'Clears the original sheet:
With WS
   .Range("D2").ClearContents
   .Range("D6").ClearContents
   .Range("A31").ClearContents
   .Range("B31").ClearContents
   .Range("C31").ClearContents
   .Range("D31").ClearContents
   .Range("A34:B37").ClearContents
   .Range("C34:D37").ClearContents
   .Range("A40:B43").ClearContents
   .Range("C40:D43").ClearContents
   .Range("A46").ClearContents
   .Range("B46").ClearContents
   .Range("C46").ClearContents
   .Range("D46").ClearContents
   For Each oleObj In WS.OLEObjects
      If oleObj.progID = "Forms.TextBox.1" Then oleObj.Object.Value = ""
   Next oleObj
   Dim Shp As Shape
 For Each Shp In ActiveSheet.Shapes
   If Shp.Type = msoTextBox Then
     Shp.TextFrame.Characters.Text = ""
   End If
 Next Shp
End With
 
Else
   Set checkWs = Nothing
   MsgBox "Uusi taulukko voidaan lisätä huomenna."
End If
End Sub
 
Upvote 0
Just noticed, I don't need to have those clearcontent-codes.

Here's the thing;

One sheet is called "Default", and it has data validation lists, textboxes, comboboxes etc, we don't change anything on this sheet.

Then I use this code to add new sheet;

Code: 
Sub NewSheet()
Sheets("Default").Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Format(Date, "dd.mm.yyyy")
End Sub

And when this new sheet appears, named after specific date, everything's restored, ok?? I can do changes, write text etc everything I want, and when I select "add new sheet", it gives me an new sheet, named after specific date and it looks like "default-sheet".

But what I still need, is that user CANNOT/IS UNABLE TO add more than ONE sheet.

Like this;

Today is 7.21.2011, I select "add new sheet", it gives me an error and messagebox that says "you can add new sheet tomorrow".

When I'm using code ABOVE, it adds more and more sheets everytime I press "add new sheet", but in code BELOW, it gives me a message and I'm not allowed to add more sheets until next day.

Code: 
Sub NewSheet()
Dim CurrentDay As Integer, NewName As String
If IsNumeric(Right(ActiveSheet.Name, 2)) Then
   CurrentDay = Right(ActiveSheet.Name, 2)
ElseIf IsNumeric(Right(ActiveSheet.Name, 1)) Then
   CurrentDay = Right(ActiveSheet.Name, 1)
Else
   Exit Sub
End If
CurrentDay = CurrentDay + 1
NewName = Format(Date, "dd.mm.yyyy")
Dim checkWs As Worksheet
On Error Resume Next
Set checkWs = Worksheets(NewName)
If checkWs Is Nothing Then
   Worksheets(ActiveSheet.Name).Copy After:=Worksheets(ActiveSheet.Index)
  Dim oleObj As OLEObject
With ActiveSheet
   .Name = NewName
   .Range("D2").ClearContents
   .Range("D6").ClearContents
   .Range("A31").ClearContents
   .Range("B31").ClearContents
   .Range("C31").ClearContents
   .Range("D31").ClearContents
   .Range("A34:B37").ClearContents
   .Range("C34:D37").ClearContents
   .Range("A40:B43").ClearContents
   .Range("C40:D43").ClearContents
   .Range("A46").ClearContents
   .Range("B46").ClearContents
   .Range("C46").ClearContents
   .Range("D46").ClearContents
   For Each oleObj In ActiveSheet.OLEObjects
      If oleObj.progID = "Forms.TextBox.1" Then oleObj.Object.Value = ""
   Next oleObj
   Dim Shp As Shape
 For Each Shp In ActiveSheet.Shapes
   If Shp.Type = msoTextBox Then
     Shp.TextFrame.Characters.Text = ""
   End If
 Next Shp
End With
 
Else
   Set checkWs = Nothing
   MsgBox "Uusi taulukko voidaan lisätä huomenna."
End If
End Sub

So could you tell me how to connect these two codes.


AND ALSO, HOW DO I PROTECT THIS "DEFAULT-SHEET" SO THAT NO ONE CAN'T CHANGE ANYTHING, 'CUZ I HIDE IT, MACROS DON'T WORK SOMEHOW :P
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Help with VBA Code in Excel
Replies
2
Views
338
tixarah
T
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
351
Minh Tuan VN
M
Agnarr
  • Question Question
VBA problem with creating new sheets
Replies
0
Views
823
Agnarr
Agnarr
A
  • Solved
VBA Help!
Replies
2
Views
429
AusNewb
A
K
  • Solved
Help please - Code keeps pasting 34 rows instead of 1
Replies
4
Views
574
Fluff
Fluff

Forum statistics

Threads
1,224,597
Messages
6,179,813
Members
452,945
Latest member
Bib195

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top