Příspěvky uživatele

Jedna připomínka :-).
Na listu "NAJ" to moc nesedí, na pozici 6 je GRO se 73 hodinama, ten samý je pak i na pozici 8 se 74 hodinama. Správně by na pozici 8 měl být VAS.

Jako řešení by mohl posloužit POKIho příspěvek v nedávném článku http://wall.cz/index.php?m=topic&id=1626

M@

Ahoj,

pro načítání v preferencích projektu používám Microsoft Scripting Runtime knihovnu - stačí zaškrtnout.

Pak by kód mohl vypadat nějak takto:
Sub nacti()
Dim fso As New FileSystemObject
Dim fil As File
Dim ts As TextStream
Dim text() As String
Dim radek As Single

radek = 1

Set fil = fso.GetFile(ThisWorkbook.Path & "\soubor.txt")
Set ts = fil.OpenAsTextStream(ForReading)

For i = 1 To 4
ts.SkipLine
Next

Do While ts.AtEndOfStream = False
text = Split(ts.ReadLine, " ")
Cells(radek, 1) = text(3)
Cells(radek, 2) = text(4)
radek = radek + 1
Loop

End Sub
ale trochu mě mate těch 7 sloupců oddělených mezerami různých délek - asi by bylo dobré ten texťák vidět.

M@

Ahoj,
asi bych si vedle jména přidal další sloupec s funkcí =DEN(datum) případně v kombinaci s &"_"&MĚSÍC(datum) a na tento sloupec bych pak použil do dalšího sloupce funkci =COUNTIF(nový sloupec;buňka na daném řádku nového sloupce), v tomto sloupci pak použít aut. filtr >1.

M@

Zkusím přidat ještě jeden příklad:
Public Sub spustit()
Dim soubor As String
soubor = "D:\CPR.mdb"

If Dir(soubor) <> "" Then
Set wshShell = CreateObject("WScript.Shell")
wshShell.Run (soubor)
Else
MsgBox "Soubor nenalezen", vbCritical, "Chyba"
End If
End Sub
jinak třeba se bude hodit:
http://www.david-zbiral.cz/vb.htm
S pozdravem
M@

Než jsem to napsal tak už to má Poki :-)

Tady je to i s tím dotazem, nicméně to neřeší heslo:
Public Sub overeni()
Dim dotaz As String
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets(i).ProtectContents = True Then
dotaz = MsgBox("List " & Chr(34) & Sheets(i).Name & Chr(34) & " je zamčený, přejete si odemknout?", vbYesNo + vbQuestion, "Odemknout")
If dotaz = vbYes Then Sheets(i).Unprotect
Else
dotaz = MsgBox("List " & Chr(34) & Sheets(i).Name & Chr(34) & " není zamčený, přejete si zamknout?", vbYesNo + vbQuestion, "Odemknout")
If dotaz = vbYes Then Sheets(i).Protect
End If
dotaz = none
Next
End Sub

Ještě by teda před každým sheets mohlo být activeworkbook, ale asi to není tak důležité.
M@

Ahoj, v klasickém VB jdou prvky s indexem přidávat pomocí load a pak visible a pro zpětné projíždění stačí projet indexy viz odkaz:
http://articles.techrepublic.com.com/5100-10878_11-5458636.html
toto mám ve VB6 odzkoušené, ale asi to nepůjde použít ve VBA, kde indexy nejsou.
Ještě jsem vygooglil další dva návody, ale žádný z nich jsem netestoval, tak je to na tobě :-):
http://www.a1vbcode.com/vbtip-117.asp
http://www.programmersheaven.com/mb/VBasic/336815/336815/creating-image-boxes-at-run-time/
ten druhý s využitím control.add by mohl fungovat - tuto funkci jsem ve VBA viděl ;-)

M@

Ahoj, zkus tohle:
Dim xpos As Single
Dim ypos As Single
Dim indicator As Single

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
xpos = X
ypos = Y
indicator = 1
End Sub

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If indicator = 1 Then
Image1.Left = X - xpos + Image1.Left
Image1.Top = Y - ypos + Image1.Top
End If
End Sub

Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
indicator = 0
End Sub

M@

Ahoj, mám pocit že to nějak moc elegantně nejde. Napadá mě jediný způsob jak to obejít:
vybrat oblast buněk které chceš mít orámovány, v kreslení zapnout stín (jakykoliv), tento pak nastavit bez stínu nicméně buňkám zůstane ohraničení a toto pak změnit v panelu nástrojů Kreslení -> Změnit automatický tvar -> Základní tvary -> zaoblený obdelník.
Jinak to asi nepůjde.
M@

Já teda asi jen k tomu bodu 4 :-)
Určitě bych nepoužíval fixní cestu
"D:\PROGRAMY\TEST UCTO\Otazky ucto.txt"
ale spíš
Thisworkbook.path & "\Otazky ucto.txt"
S tím časem v excelu jde snad jedině využít příkazu application.ontime
Další body jsou na delší bádání.

M@

I to se může stát, že občas nepochopím zadání :-).
Pak je ten Váš vzorec OK. Já můžu nabídnou zas třeba ten s funkcí A :-), jen teda trochu upravenej.
=A(C2<=D2;D2<=E2;E2<=F2;F2<=G2;G2<=H2) přeci jen při použití vnořených KDYŽ to lze zopakovat asi jen 7x, kdežto v A lze použít až 30 podmínek. No a pro označení nesprávných buněk bych použil podmíněné formátování, tak aby neodpovídající buňky byly barevně označeny.

M@

Ahoj,

v tvém vzorci porovnáváš vždy 2 sousední sloupce, ale co když rozdíl bude ve sloupcích D a H?
Dále ve vzorci používáš C2>D2, ale co když D2 bude větší než C2? :-) Například na řádku 3 máš co sloupec to jiná hodnota a přesto máš vyhodnoceno jako OK - Tady když už tak by bylo lepší použít C2<>D2.
Napadla mě například funkce A a každý s každým, sice ti to neřekne kde je rozdíl, ale porovná opravdu všechny.
=A(C2=D2;C2=E2;C2=F2;C2=G2;C2=H2;D2=E2;D2=F2;D2=G2;D2=H2;E2=F2;E2=G2;E2=H2;F2=G2;F2=H2;G2=H2)

další trochu zjednodušenou možností je suma všech / počet a porovnat to s třeba prvním sloupcem, ani zde ti to neřekne kde je rozdíl, jen že tam je rozdíl.

=KDYŽ(SUMA(C2:H2)/POČET2(C2:H2)<>C2;"KO";"OK")

Snad to k něčemu bude :-)
M@

Nevím jestli chápu v čem je problém, jestli v tom ověření dat, nebo v tom tisku.
If Application.WorksheetFunction.CountA(Range("$A$63:$S$134")) > 0 Then
ActiveSheet.PageSetup.PrintArea = "$A$1:$S$62"
ActiveSheet.PrintOut
ActiveSheet.PageSetup.PrintArea = "$A$63:$S$134"
ActiveSheet.PrintOut
Else
ActiveSheet.PageSetup.PrintArea = "$A$1:$S$62"
ActiveSheet.PrintOut
End If

Ahoj,

možností je spousta :-).

Jinak jo, kopírovaz ze skrytých i velmi skrytých listů lze, jen nemůžeš použít příkazy select ani selection, ale provést přímo
Sheets("123").Range("D13:P124").Copy

M@

Posílám 3 pokusy :-)

1) kopírování musí být spuštěno z každého case samostatně.
Public Sub pok1()
Select Case Range("S5").Value
Case Is = 0.02
Sheets("0,02").Select
Case Is = 0.01
Sheets("0,01").Select
Case Is = 0.025
Sheets("0,025").Select
Case Else
MsgBox "já ti nevím"
End Select
End Sub
2) U každého case zapiš do proměnné název a na konci vyhodnoť proměnnou a proveď další akce:
Public Sub pok2()
Dim listn As String
Select Case Range("S5").Value
Case Is = 0.02
listn = "0,02"
Case Is = 0.01
listn = "0,01"
Case Is = 0.025
listn = "0,025"
End Select

If listn <> "" Then
Sheets(listn).Select
'kopíruj
Else
MsgBox "já ti nevím"
End If
End Sub

3) ověř všechny hodnoty v jednom kroku a otevři list na základě hodnoty (je-li hodnota v seznamu), jinak msgbox:
Public Sub pok3()
Dim listn As String
Select Case Range("S5").Value
Case Is = 0.02, 0.01, 0.025
listn = Range("S5").Value
Sheets(listn).Select
Case Else
MsgBox "já ti nevím"
End Select
End Sub

M@

Ahoj, než vymýšlet jak toho docílit vzorcem, tak je rychlejší napsat makro, případně vlastní funkci.
Zkusil jsem to přes makro:

Public Sub oznac()
For Each cell In Range("RESTAURACE")
For Each cell2 In Range("OBCE")
If InStr(1, cell, cell2) <> 0 Then cell.Interior.Color = vbRed
Next
Next
End Sub

podmínkou je mít pojmenované oblasti:
RESTAURACE = seznam všech restaurací (např. A1:A100)
OBCE = seznam všech obcí (např. B1:B20)

M@

Příspěvky uživatele

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje