http://wall.cz/index.php?m=topic&id=16247citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Přidání listu s aktuální datem
Omyl:
Sheets("VZOR").Visible = True
Misto
ActiveWindow.SelectedSheets.Visible = True
Ale dekuji mockrat..
Ted jsem se vrhl na ještě složitější makro tak jsem zvedavcitovat
jojo to máš pravdu = v jednoduchosti je síla
děkujicitovat
MS Excel
Téma: Přidání listu s aktuální datem 
Zaslal/a Fantasyk 6.8.2020 19:32
Ahojte,
mám takoví problém přidám list přejmenuji ho podle aktuálního data, ale nastane problém, když někdo v jeden den klikne 2x ( napíše to chybu, jelikož se název listu už v sešitu nachází 
)
Sub add()
Sheets("VZOR").Visible = True
Dim copr As String
copr = ActiveSheet.Name
Sheets.add After:=Worksheets(Sheets.Count):
Range("A1").Value = Format(Now, "dd.mm.yyyy")
Range("A1").Select
Selection.Value = WorksheetFunction.Text(Selection, "dd.mm.yyyy")
bunka = Range("A1").Value
ActiveSheet.Name = bunka
Worksheets("VZOR").Select
Cells.Select
Selection.Copy
ActiveWindow.SelectedSheets.Visible = False
Sheets(bunka).Activate
Cells.Select
ActiveSheet.Paste
ActiveWindow.Zoom = 55
End Sub
vím, že to bude nějaké if a else, ale nějak mi to do toho nejde zakomponovat 
Jen, aby to napsalo :
MsgBox "Nelze přidat, jelikož se den už v sešitě nachází", vbExclamation
Díky moc za radu
(6.8.2020 20:47)#047610
V polospánku :
Sub add()
Dim WS As Worksheet, Nazov As String
Nazov = Format(Now, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazov)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze přidat, jelikož se den už v sešitě nachází", vbExclamation: Exit Sub
Worksheets("VZOR").Visible = True
Worksheets("VZOR").Copy After:=Worksheets(Worksheets.Count)
Worksheets("VZOR").Visible = False
Set WS = Worksheets(Worksheets.Count)
WS.Range("A1").Value = Nazov
WS.Name = Nazov
ActiveWindow.Zoom = 55
End Subcitovat
Sub add()
Dim WS As Worksheet, Nazov As String
Nazov = Format(Now, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazov)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze přidat, jelikož se den už v sešitě nachází", vbExclamation: Exit Sub
Worksheets("VZOR").Visible = True
Worksheets("VZOR").Copy After:=Worksheets(Worksheets.Count)
Worksheets("VZOR").Visible = False
Set WS = Worksheets(Worksheets.Count)
WS.Range("A1").Value = Nazov
WS.Name = Nazov
ActiveWindow.Zoom = 55
End Subcitovat
tak to elninoslov nefungovalo, ale upravil jsem trochu to tvojeSub add()
Dim WS As Worksheet, Nazev As String
Nazev = Format(Now, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazev)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze pridat, jelikož se aktuální den už v sešite nachází!", vbExclamation: Exit Sub
Dim copr As String
copr = ActiveSheet.Name
Sheets.add After:=Worksheets(Sheets.Count):
Range("A1").Value = Format(Now, "dd.mm.yyyy")
Range("A1").Select
Selection.Value = WorksheetFunction.Text(Selection, "dd.mm.yyyy")
bunka = Range("A1").Value
ActiveSheet.Name = bunka
ActiveWindow.SelectedSheets.Visible = True
Worksheets("VZOR").Select
Cells.Select
Selection.Copy
ActiveWindow.SelectedSheets.Visible = False
Sheets(bunka).Activate
Cells.Select
ActiveSheet.Paste
ActiveWindow.Zoom = 55
End Subcitovat
Dim WS As Worksheet, Nazev As String
Nazev = Format(Now, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazev)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze pridat, jelikož se aktuální den už v sešite nachází!", vbExclamation: Exit Sub
Dim copr As String
copr = ActiveSheet.Name
Sheets.add After:=Worksheets(Sheets.Count):
Range("A1").Value = Format(Now, "dd.mm.yyyy")
Range("A1").Select
Selection.Value = WorksheetFunction.Text(Selection, "dd.mm.yyyy")
bunka = Range("A1").Value
ActiveSheet.Name = bunka
ActiveWindow.SelectedSheets.Visible = True
Worksheets("VZOR").Select
Cells.Select
Selection.Copy
ActiveWindow.SelectedSheets.Visible = False
Sheets(bunka).Activate
Cells.Select
ActiveSheet.Paste
ActiveWindow.Zoom = 55
End Subcitovat
Pošlite prílohu,nech je jasné odkiaľ makro spúšťate a čo je v listoch. Z toho sa bude dať snáď vydedukovať, čo chcete urobiť.citovat
Fantasyk napsal/a:
tak to elninoslov nefungovalo, ale upravil jsem trochu to tvojeSub add()
Dim WS As Worksheet, Nazev As String
Nazev = Format(Now, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazev)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze pridat, jelikož se aktuální den už v sešite nachází!", vbExclamation: Exit Sub
Dim copr As String
copr = ActiveSheet.Name
Sheets.add After:=Worksheets(Sheets.Count):
Range("A1").Value = Format(Now, "dd.mm.yyyy")
Range("A1").Select
Selection.Value = WorksheetFunction.Text(Selection, "dd.mm.yyyy")
bunka = Range("A1").Value
ActiveSheet.Name = bunka
ActiveWindow.SelectedSheets.Visible = True
Worksheets("VZOR").Select
Cells.Select
Selection.Copy
ActiveWindow.SelectedSheets.Visible = False
Sheets(bunka).Activate
Cells.Select
ActiveSheet.Paste
ActiveWindow.Zoom = 55
End Sub
Omyl:
Sheets("VZOR").Visible = True
Misto
ActiveWindow.SelectedSheets.Visible = True
Ale dekuji mockrat..
Ted jsem se vrhl na ještě složitější makro tak jsem zvedavcitovat
A nestačilo by to jen takhle jednoduše?
Sub Add()
Dim WS As Worksheet
Dim Nazev As String
Nazev = Format(Date, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazev)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze přidat, jelikož se aktuální den už v sešite nachází!", vbExclamation: Exit Sub
Sheets("VZOR").Visible = True
Sheets("VZOR").Copy After:=ActiveSheet
ActiveSheet.Name = Nazev
ActiveWindow.Zoom = 100
ActiveSheet.Range("A1").Select
Sheets("VZOR").Visible = False
End Sub
Sub Add()
Dim WS As Worksheet
Dim Nazev As String
Nazev = Format(Date, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazev)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze přidat, jelikož se aktuální den už v sešite nachází!", vbExclamation: Exit Sub
Sheets("VZOR").Visible = True
Sheets("VZOR").Copy After:=ActiveSheet
ActiveSheet.Name = Nazev
ActiveWindow.Zoom = 100
ActiveSheet.Range("A1").Select
Sheets("VZOR").Visible = False
End Sub
Příloha: 
47622_add-sheets.zip (19kB, staženo 17x)
citovat47622_add-sheets.zip (19kB, staženo 17x)lugr napsal/a:
A nestačilo by to jen takhle jednoduše?
Sub Add()
Dim WS As Worksheet
Dim Nazev As String
Nazev = Format(Date, "dd.mm.yyyy")
On Error Resume Next
Set WS = Worksheets(Nazev)
On Error GoTo 0
If Not WS Is Nothing Then MsgBox "Nelze přidat, jelikož se aktuální den už v sešite nachází!", vbExclamation: Exit Sub
Sheets("VZOR").Visible = True
Sheets("VZOR").Copy After:=ActiveSheet
ActiveSheet.Name = Nazev
ActiveWindow.Zoom = 100
ActiveSheet.Range("A1").Select
Sheets("VZOR").Visible = False
End SubPříloha: 47622_add-sheets.zip (19kB, staženo 0x)
jojo to máš pravdu = v jednoduchosti je síla
děkujicitovat
Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články