• Úvod
• Excel návod
• Excel šablony
• Nástěnka
• Mobility
• Tipy na výlet
• Galerie
• Fórum

Příspěvky uživatele

Zrovna jsem se na to díval.
Ani SpecialCells(xlCellTypeLastCell) není dobrý, protože bere v potaz jen viditelné buňky.
Máš pravdu s ActiveSheet.UsedRange, ale zkus si na řádku 1000 změnit výšku řádku. Zas je to v prd.
Takže asi kombi.
Sub AdresaPosledniBunky()
MsgBox PosledniPlna(ActiveSheet).Address(, , xlR1C1), , "PosledniPlna"
End Sub

Function PosledniPlna(ws As Worksheet) As Range
Dim uRng As Range, rdLast As Long, slLast As Long
Set PosledniPlna = ActiveSheet.UsedRange
rdLast = PosledniPlna.Row + PosledniPlna.Rows.Count
slLast = PosledniPlna.Column + PosledniPlna.Columns.Count
Do While WorksheetFunction.CountBlank(Range(Cells(1, slLast), Cells(rdLast, slLast))) = rdLast
slLast = slLast - 1
Loop
Do While WorksheetFunction.CountBlank(Range(Cells(rdLast, 1), Cells(rdLast, slLast))) = slLast
rdLast = rdLast - 1
Loop
Set PosledniPlna = Cells(rdLast, slLast)
End Function

Tak ta fce pro sloupec je špatná.
Je to třeba zpracovat bohužel cyklem.
Sub PosledniPlna()
Dim rdlast As Long, slLast As Long
rdlast = Cells.SpecialCells(xlCellTypeLastCell).Row
slLast = Cells.SpecialCells(xlCellTypeLastCell).Column
Do While WorksheetFunction.CountBlank(Range(Cells(1, slLast), Cells(rdlast, slLast))) = rdlast
slLast = slLast - 1
Loop
Do While WorksheetFunction.CountBlank(Range(Cells(rdlast, 1), Cells(rdlast, slLast))) = slLast
rdlast = rdlast - 1
Loop
MsgBox Cells(rdlast, slLast).Address, , "PosledniPlna"
End Sub

Vymazat tu vatu by šlo v tom cyklu (včetně formátů!), ale EXCEL je nevyzpytatelný. Pokud to nejde přes CLEAR, je nutno List-Sešit kopnout do nového. Dělám to celkem pravidelně.

No teda ty mi dáváš. Tak že od začátku. Na jedmon PC se zapisuje pouze LK malé a na druhém PC pouze LK velké. Ano?
Proč nejsou dva sešity pro zápis každé evidenci zvlášť? Proč obě v jednom, když se zapisuje pouze do jedné? Tyto evidence můžou ukládat vlastní reporty. A pak může existovat třetí sešit, který bude načítat obě tabulky. Tam se pak můžou dělat opravy před tiskem atd. Nebo jak to teda je?

Protože s Cells.SpecialCells(xlCellTypeLastCell) jsou opravdu problémy napsal jsem si vlastní funkci.
Problém je, že zatím nebere v potaz formáty.
Ale i to by šlo dodělat. Tak zatím takto.
Sub AdresaPosledniBunky()
Dim celLast As Range, sh As Byte
For sh = 1 To ThisWorkbook.Sheets.Count
With Sheets(sh)
Set celLast = .Cells(PosledniRadek(Sheets(sh)), PosledniSloupec(Sheets(sh)))
If celLast.Address = Cells(1).Address And IsEmpty(.Cells(1)) Then
MsgBox "list je prazdny", , "List" & sh
Else
MsgBox "posledni bunka = " & celLast.Address, , "List" & sh
End If
End With
Next sh
Set celLast = Nothing
End Sub

Function PosledniRadek(ws As Worksheet) As Long
Dim aktOblast As Range, arLast As Long
On Error Resume Next
With ws
arLast = .Cells.RowDifferences(.Cells(1)).Areas.Count
If Err = 0 Then
Set aktOblast = .Cells.RowDifferences(.Cells(1)).Areas(arLast)
PosledniRadek = aktOblast.Row + aktOblast.Rows.Count - 1
Set aktOblast = Nothing
Else
Err.Clear
PosledniRadek = .Cells(.Columns(1).Rows.Count, 1).End(xlUp).Row
End If
End With
On Error GoTo 0
End Function

Function PosledniSloupec(ws As Worksheet) As Long
Dim aktOblast As Range, arLast As Long
On Error Resume Next
With ws
arLast = .Cells.ColumnDifferences(.Cells(1)).Areas.Count
If Err = 0 Then
Set aktOblast = .Cells.ColumnDifferences(.Cells(1)).Areas(arLast)
PosledniSloupec = aktOblast.Column + aktOblast.Columns.Count - 1
Set aktOblast = Nothing
Else
Err.Clear
PosledniSloupec = .Cells(1, .Rows(1).Columns.Count).End(xlToLeft).Column
End If
End With
On Error GoTo 0
End Function

EXCEL - CTRL+END
VBA - Cells.SpecialCells(xlCellTypeLastCell)

Po příkazu Paste je třeba vložit
Application.CutCopyMode = False

jinak je lépe, pokud je to možné, používat
Range().Copy Range()

Ta složka Archiv slouží jen po dobu vývoje.
Pak se může odstranit.
Reporty se ukládají do složky Formulare.

1)v proceduře Pro_Tisk()
v oddílu With Sheets("TISK")
po řádku
Sheets("Evidence").Range("A1:N" & rdLast).Copy .Range("A1")
například:
.Cells(1, 14) = Sheets("Evidence").Cells(1, 21)
.Cells(1, 14).Font.ColorIndex = 2
.Cells(2, 14) = Sheets("Evidence").Cells(2, 21)
.Cells(2, 14).Font.ColorIndex = 2
2)obecně nastavení oblasti tisku:
ActiveSheet.PageSetup.PrintArea = Range(Cells(a, b), Cells(x, y))

ale dá se i přímo tisknout zadaná oblast
v proceduře Akce_Tisk()
nastavit Vzhled stránky (ze záznamníku)
a pak:
For eTab = 1 To 2
rdW = (eTab - 1) * Cells(1, 14) + 1
rdLast = Cells(eTab, 14)
ActiveSheet.Range(Cells(rdW, 1), Cells(rdLast, 13)) _
.PrintOut Copies:=1, _
ActivePrinter:="\\Pcraw\HP Deskjet F4100 series na Ne01:" 'dosadit svou tiskárnu
Next eTab
Tu cestu k tiskárně není třeba nastavovat, pokud je v nastavení tisku již nastavena (default).

Možná se pletu, ale koukl bych do regedit, jaká je tam nastavena volba pro Local.
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Jet\4.0\Engines\Text
Format = Delimited(;)

Choose - help
http://office.microsoft.com/cs-cz/access-help/funkce-choose-HA001228797.aspx

Month(Response) je zde jako index. Položky seznamu musíš naplnit.
Choose(Month(Response),"Leden",...,"Cervenec",...)

1)Samozřejmě:
'Pod kód
'pro novy rok zalozi novou slozku
MyHelp = ThisWorkbook.Path & "\E-BASE\Formulare\" & Year(Response)
On Error Resume Next
NameDB = GetAttr(MyHelp) And vbDirectory = vbDirectory
If Not Err = 0 Then MkDir MyHelp
'přidáš
'pro novy mesic zalozi novou slozku
Err.Clear
MyHelp = MyHelp & "\" & Format(Response, "mmmm")
NameDB = GetAttr(MyHelp) And vbDirectory = vbDirectory
If Not Err = 0 Then MkDir MyHelp
On Error GoTo 0
Zde ale bych byl opatrný, diakritika v názvech souborů či složek může působit problémy.
'Raděj bych se držel číselného označení měsíce,
MyHelp = MyHelp & "\" & Month(Response)

'nebo název měsíce bez diakritiky
MyHelp = MyHelp & "\" & Choose(Month(Response),"Leden",...,"Cervenec",...)

2)Tak jak je popsáno. Pouze ukázka. Může se vložit nějaká další procedura, nebo jen vymazat.
3)Přesně tak. Umíš nastavovat OBLAST TISKU? Pohrej si se záznamníkem maker. Většinu z toho ti ukáže.
Taky bude dobré spolu s tabulkami přenést i hodnoty ze sloupce 21. Pak budeš znát velikost tabulek.
4)Samozřejmě.

Ještě v proceduře Pro_Tisk() si změň zápis.

'Místo

End If
On Error GoTo 0
With Sheets("TISK")
.Activate
.Cells.Clear
rdLast = Sheets("Evidence").Cells.SpecialCells(xlCellTypeLastCell).Row

'Tam dej

End If
With Sheets("TISK")
.Activate
.Cells.Clear
.Shapes("Logo 1").Delete
.Shapes("Logo 2").Delete
On Error GoTo 0
rdLast = Sheets("Evidence").Cells.SpecialCells(xlCellTypeLastCell).Row

No něco jsem napsal. Nevím přesně jak to má fachčit, co to má dělat, snad ti to pomůže. Není to odladěné, tak jestli tam jsou nějaké chyby, nebo nebudeš něco vědět tak napiš.

Chtěl jsem vědět kde a jak v listě oprava se budou vypisovat ty kódy operací(řádkování). Asi pod každou zvlášť? Tisknout se bude každá zvlášť, nebo?
A co kdyby byl každý stroj(tabulka) zvlášť na samostatném listu? Nebo tak jak to je?

Podívej se na funkce Excelu - ZAOKROUHLIT()

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse