< návrat zpět

MS Excel


Téma: Vložení listu a odkazování se na něj. rss

Zaslal/a icon 18.8.2012 17:34

Ahojte, mám menší problém a netuším, jak se s ním pohnout...

Jde o toto :

Potřebuji jedním makrem vytvořit list a zkopírovat do něj tabulku z jiného listu, ovšem bez vzorců...
Problém nastává, když se pak na tento list chci opět makrem odkázat z důvodu přepsání jména listu... netuším, jak se na tento list odkázat, když předem neznám jeho název....díky za pomoc.

stop Uzamčeno - nelze přidávat nové příspěvky.

Strana:  1 2 3   další »
icon#009275
avatar
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
icon#009286
avatar
Díky moc, to druhé řešení je přesně to co potřebuji, ale jak ošetřit, aby to neházelo chybovou hlášku, když soubor již list se stejným jménem obsahuje ? Stačí mi jak vyhledat jméno listu... pak bych jej jen smazal a pokračoval v kodu, diky moc.citovat
icon#009293
avatar
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
icon#009302
avatar
Perfektní díky moc, přesně takhle jsem si to představoval...citovat
icon#009309
avatar
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
icon#009310
avatar
Tak už vím, kde je chyba, výšky řádků nejsou shodné, ale co netuším, je to, jak je to možné, když by se formáty měly kopírovat...

Předem díky za jakoukoliv pomoc.citovat
icon#009312
avatar
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
icon#009321
avatar
Perfektní !!!

Musím uznat, že jsi opravdu dobrý... Nyní vše funguje tak jak má.

Thumbs up !citovat
icon#009322
avatar
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
icon#009330
avatar
To je už třetí téma v jednom.

1)U metody InputBox je vhodné ošetřit stav, kdy toto okno zrušíš.
t = Application.InputBox("Zadej poznámku")
If StrPtr(t) = 0 Then Exit Sub

2)Uniká mi smysl první části procedury If t = "" Then

3)Procedura obsahuje dvakrát kód
If t <> "" Then Cells(rd, sl) = t
=> "t" je přidáno do sloupce(22) dvakrát po sobě?!

asi by bylo lépe napsat jednou If t <> "" Then
a pak pro obě tab
With Union(Range("M8:M28"),Range("M43:M63")).Validation

4)Píšeš: "Jde o to, že přidávám pomocí makra poznámky do rozevíracího seznamu".
Nebo do Sloupce(22)?

5)Píšeš "makro nebere nové řádky v potaz". Co tím myslíš?
Máš na mysli: zdroj seznamu v ověření dat nebere nové řádky v potaz?

6)Pokud přidáváš řádek "Rows(xx).Insert",
pak se zdroj seznamu v ověření upraví automaticky.

Pokud nepřidáváš řádek, ale hodnotu do dalšího řádku v sloupci(22)
a chceš aby se tato hodnota přidala do zdroje,
pak je možné například pro max 100 záznamů v sloupci(22)
do zdroje seznamu v ověření dat vložit
=POSUN(R8C22;;;POČET2(R8C22:R108C22))
=POSUN($V$8;;;POČET2($V$8:$V$108))

Pokud přidáváš poznámky pouze pomocí makra,
můžeš ten odkaz ve zdroji po každém přidání nového záznamu v tom makru přepsat.
V tom případě tady v tvém kódu nevidím žádný problém.

Ještě dodatek:
pro test prázdné buňky je lépe místo
If Cells(rd, sl) <> "" Then
používat
If Not IsEmpty(Cells(rd, sl)) Then

a jinak ten cyklus
Do While Cells(rd, sl) <> ""
rd = rd + 1
Loop
lze nahradit
rd = Cells(8, 22).End(xlDown).Row + 1
rd = Cells(108, 22).End(xlUp).Row + 1citovat

Strana:  1 2 3   další »

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Novinky

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

test897

vvv456554 • 21.10. 18:26

test897

test897 • 21.10. 18:23

Automatické vyplnování datumu ve vedlejší buňce

Stalker • 21.10. 17:17

Vyplnenie povinných polí

mae • 21.10. 14:40

Automatické vyplnování datumu ve vedlejší buňce

h.paslik • 21.10. 14:34

otevření *.xls a jeho uložení jako 1 2 3.xls

yerome1 • 21.10. 13:36

otevření *.xls a jeho uložení jako 1 2 3.xls

Dingo • 21.10. 13:24