Příspěvky uživatele


< návrat zpět

Strana:  1 ... « předchozí  14 15 16 17 18 19 20 21 22   další » ... 24
LastCell (15.10.2012 23:46)

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

LastCell (15.10.2012 22:47)

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ě.

Výtah dat (15.10.2012 21:28)

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?

LastCell (14.10.2012 22:37)

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

Uprava makra obsah do jednoho listu (14.10.2012 0:43)

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

hlášení (14.10.2012 0:35)

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()

Výtah dat (14.10.2012 0:26)

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

Výtah dat (12.10.2012 23:07)

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).

uložení do csv (11.10.2012 19:22)

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(;)

Výtah dat (11.10.2012 19:05)

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",...)

Výtah dat (10.10.2012 20:42)

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ě.

Výtah dat (9.10.2012 23:42)

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

Výtah dat (7.10.2012 21:29)

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š.

Výtah dat (1.10.2012 20:13)

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?

Zaokrouhlování (30.9.2012 23:27)

Podívej se na funkce Excelu - ZAOKROUHLIT()


Strana:  1 ... « předchozí  14 15 16 17 18 19 20 21 22   další » ... 24

Uživatelské menu

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

Menu

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.

On-line nástroje