MS Excel

1)Při přidání mu přiřadit Jméno:
Sheets.Add.Name = "NovyList"

2)Po přidání je Aktivním Listem.
Dim JmnLst As String
Sheets.Add
JmnLst = ActiveSheet.Name
Sheets(JmnLst).Name = "NovyList"
citovat

Myslíš toto ?
Sub PridatNovyList()
Dim JmnLst As String
Application.EnableEvents = False
On Error Resume Next
Sheets("NovyList").Select
If Err.Number = 0 Then
If MsgBox("Odstranit List /NovyList ?", vbExclamation + vbYesNo) = vbYes Then
Application.DisplayAlerts = False
Sheets("NovyList").Delete
Application.DisplayAlerts = True
Else
GoTo KONEC
End If
End If
On Error GoTo 0
Sheets.Add.Name = "NovyList"
KONEC:
Application.EnableEvents = True
End Sub
citovat

Tak teď jsem přišel na to, že to až tak perfektní neni... Hází mi to totiž chybovou hlášku :

Run-time error 1004 Při této operaci musí mít sloučené buňky stejnou velikost. (Buňky jsou kopírovány, takže by měly mít stejnou velikost... )

Mám jakousi tabulku, kterou potřebuju překopírovat tak, aby se kopírovaly jen hodnoty a formáty buněk s ohraničením...

V označeném textu se mi zastaví debugger a nahlásí chybu viz, výše... co s tím ?

Tady raději přikládám kod...

Sub Kopirovani_stranky_za_ucelem_oprav()
Dim JmnLst As String

Application.EnableEvents = False
On Error Resume Next
Sheets("Oprava").Select
If Err.Number = 0 Then
If MsgBox("Odstranit List /Oprava ?", vbExclamation + vbYesNo) = vbYes Then
Application.DisplayAlerts = False
Sheets("Oprava").Delete
Application.DisplayAlerts = True
Else
GoTo KONEC
End If
End If
On Error GoTo 0
Sheets.Add.Name = "Oprava"
KONEC:
Application.EnableEvents = True
Sheets("Hárok1").Select
Columns("A:N").Select
Range("A2").Activate
Selection.Copy
Sheets("Oprava").Select
Range("A1").Select
ActiveWindow.Zoom = 75
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("P21").Select
Range("O5").Select
Sheets("Oprava").Select
Application.CutCopyMode = False
Sheets("Oprava").Move After:=Sheets(3)

End Subcitovat

Aby se zkopírovaly i výšky řádků, musel bys označit i celé řádky tzn. kopírovat celý List. Taky by bylo vhodné šetřit těmi "Select". Zdržuje to kód. Já bych to napsal takto.Sub Kopirovani_stranky_za_ucelem_oprav()
Dim xCel As Range, xRdSl As Long, rdLast As Long
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Sheets("Oprava").Select
If Err.Number = 0 Then
If MsgBox("Odstranit List /Oprava ?", vbExclamation + vbYesNo) = vbYes Then
Application.DisplayAlerts = False
Sheets("Oprava").Delete
Application.DisplayAlerts = True
Else
GoTo POKRACOVAT
End If
End If
On Error GoTo 0
Sheets.Add.Name = "Oprava"
Sheets("Oprava").Move After:=Sheets(3)
POKRACOVAT:
With Sheets("Oprava")
.Activate
.Cells.Clear
rdLast = Sheets("Hárok1").Cells.SpecialCells(xlCellTypeLastCell).Row
Sheets("Hárok1").Range("A1:N" & rdLast).Copy .Range("A1")
For xRdSl = 1 To Range("A:N").Columns.Count
.Columns(xRdSl).ColumnWidth = Sheets("Hárok1").Columns(xRdSl).ColumnWidth
Next xRdSl
For xRdSl = 1 To rdLast
.Rows(xRdSl).RowHeight = Sheets("Hárok1").Rows(xRdSl).RowHeight
Next xRdSl
For Each xCel In .Range("A1:N" & rdLast)
If Not IsEmpty(xCel) Then xCel = xCel.Value
Next xCel
End With
ActiveWindow.Zoom = 75
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
citovat

Vím že už asi jsem otravný, ale když už tu je někdo, jako ty, chtěl bych tě ještě požádat, aby ses mrkl na tento kod :

Private Sub Poznamky()
'Přidá poznámku do rozevíracího seznamu ve sloupci Poznámka

Dim t As String
Dim rd As Single 'řádek
Dim sl As Single 'sloupec

t = Application.Inputbox("Zadej poznámku")

rd = 8 'začni prohledávat od řádku 8
sl = 22 'sloupec k prohledání a zápisu

If t = "" Then
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = t
' Nastavení seznamu
Range("M8:M28").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Cells(8, 22).Address & ":" & Cells(rd, sl).Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Neplatná poznámka"
.InputMessage = ""
.ErrorMessage = "Hodnota nebyla přidána do seznamu, použij tlačítko: Přidej poznámku."
.ShowInput = True
.ShowError = True
End With
End If

If t <> "" Then
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = t
' Nastavení seznamu

Range("M43:M63").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Cells(8, 22).Address & ":" & Cells(rd, sl).Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Neplatná poznámka"
.InputMessage = ""
.ErrorMessage = "Hodnota nebyla přidána do seznamu, použij tlačítko: Přidej poznámku."
.ShowInput = True
.ShowError = True
End With
End If
If t <> "" Then
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
Cells(rd, sl) = t
' Nastavení seznamu

Range("M8:M27").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=" & Cells(8, 22).Address & ":" & Cells(rd, sl).Address
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Neplatná poznámka"
.InputMessage = ""
.ErrorMessage = "Hodnota nebyla přidána do seznamu, použij tlačítko: Přidej poznámku."
.ShowInput = True
.ShowError = True
End With
End If
End Sub

Jde o to, že přidávám pomocí makra poznámky do rozevíracího seznamu....
Vše funguje jen do doby, kdy přidám řádek, jakmile jej totiž do tabulky přidám, makro nebere nové řádky v potaz... Dá se to nějak upravit, aby makro kalkulovalo i s řádky, které se postupně přidávají ? Bohužel však nikdy nevím, kolik jich bude...
Dalším problémem může být fakt, že ty tabulky jsou pod sebou dvě... jediné co mě momentálně napadlo je to, že bych stejný kód přidal hned za makro pro přidání řádku...
To však neřeší druhou tabulku...
Třeba tě napadne brilantnější řešení... každopádně díky.citovat