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

Příspěvky uživatele

Vytvorte si Definovaný názov napr. "PROVEST_VZOREC"
=EVALUATE("="&List1!$A$8)
=VYHODNOTIT("="&List1!$A$8)
a potom do C2 dajte
=IF(A2=2;PROVEST_VZOREC;4444)
=KDYŽ(A2=2;PROVEST_VZOREC;4444)

Ak pri otváraní zošitu pridáte do zabezpečenia parameter UserInterfaceOnly, zmena makrom nebude vyžadovať odomknutie, a všetko môže byť zamknuté, no nemôže byť prepojená bunka:
Private Sub Workbook_Open()
Worksheets("List1").Protect Password:="", UserInterfaceOnly:=True
End Sub
V liste potom stačí
Private Sub CheckBox1_Click()
Range("B2").Value = CheckBox1.Value
End Sub

Ak chcete prepojenú bunku, môžete ju nalinkovať do skrytého listu, nemusí byť v tom liste a zavadzať. Ten list ale bude skrytý nastavením vlastnosti
Visible = xlSheetVeryHidden
Teda nebude dostupné jeho odkrytie štandardným spôsobom, ale iba vo VBA. Potom nepotrebujete vyššie uvedené 2 kódy.

A to VBA zabezpečte tiež heslom. Aby sa nedal odokryť list, ani aby nebolo vidieť heslo vo Workbook_Open.
Tools - VBAProject Properties - Protection - Lock project for viewing + heslo

Ale zabezpečenie Excelu neberte ako nedobytné, to je skôr na zabránenie nechcenému dodrbkaniu dát, ako na zabezpečenie pred "hackerom" :)

Do modulu ThisWorkbook
Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Sh.Name <> "Vstup" Then
Dim Bunka As Range, Riadok(), bPodmienka As Boolean

On Error Resume Next
Set Bunka = Intersect(Target, Sh.Range("C2:C11")).Cells(1)
If Err.Number = 0 Then
Cancel = True
Application.EnableEvents = False
If Bunka = ChrW(10004) Then
Bunka = ""
Else
Riadok = Bunka.Offset(0, -2).Resize(, 4).Value
bPodmienka = (Not IsEmpty(Riadok(1, 1)) And IsNumeric(Riadok(1, 1))) And (Not IsEmpty(Riadok(1, 2)) And IsNumeric(Riadok(1, 2))) And Riadok(1, 2) >= Range("hodnmin") And (Not IsNumeric(Riadok(1, 4)) Or IsEmpty(Riadok(1, 4)))
Bunka = IIf(bPodmienka, ChrW(10004), "")
End If
Application.EnableEvents = True
End If
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name <> "Vstup" Then
Dim Zmena As Range, ARE As Range, OK As Range, NOK As Range, Riadky(), r As Long, hodnmin As Double

Set Zmena = Intersect(Target, Sh.Range("A2:B11,D2:D11"))

If Not Zmena Is Nothing Then
Set Zmena = Intersect(Zmena.EntireRow, Sh.Range("A2:D11"))
hodnmin = Range("hodnmin")

For Each ARE In Zmena.Areas
Riadky = ARE.Value
For r = 1 To UBound(Riadky, 1)
If Riadky(r, 3) <> "" Then
Select Case (Not IsEmpty(Riadky(1, 1)) And IsNumeric(Riadky(1, 1))) And (Not IsEmpty(Riadky(1, 2)) And IsNumeric(Riadky(1, 2))) And Riadky(r, 2) >= hodnmin And (Not IsNumeric(Riadky(r, 4)) Or IsEmpty(Riadky(1, 4)))
Case True: If OK Is Nothing Then Set OK = ARE.Cells(r, 3) Else Set OK = Union(OK, ARE.Cells(r, 3))
Case False: If NOK Is Nothing Then Set NOK = ARE.Cells(r, 3) Else Set NOK = Union(NOK, ARE.Cells(r, 3))
End Select
End If
Next r
Next ARE

Application.EnableEvents = False
If Not OK Is Nothing Then OK.Value = ChrW(10004)
If Not NOK Is Nothing Then NOK.Value = ""
Application.EnableEvents = True
End If
End If
End Sub

EDIT:
Pridal som aj reakciu na to, ak zmeníte A/B na nečíslo alebo D na číslo, prípadne zmažete - fajka zareaguje. Lebo môžete urobiť zmenu dát, ktoré stáli predtým za schválením fajky...

Tu máte iba jednoduchú úpravu, ale už minule som Vám písal, že tam môže nastať množstvo problémov (nechtiac). Filter, nesúlad medzi týždňami, prázdne bunky, nečíselné data (to máte aj teraz)... Ja som začal upravovať aj ten Váš predošlý súbor, no nedokončil. Zatiaľ.

Napr. do D2 a potiahnuť dole (ak to chcete do B, tak vo vzorci zmeniť "D1" na "B1"):=IF(AND(A3="MERGE-IN";A2="MERGE-OUT");"staré isn";IF(D1="staré isn";"nové isn";""))
=KDYŽ(A(A3="MERGE-IN";A2="MERGE-OUT");"staré isn";KDYŽ(D1="staré isn";"nové isn";""))

Ešte ma napadlo jedno riešenie
With Worksheets("Hárok1")
Intersect(.Range("B:B,D:F,J:J,N:Q,DK:DK,DM:DM,DQ:DU,DV:EB,FK:FN,FP:FP,FS:FS,FU:FY,QM:QP,QQ:QU,QV:RF,RG:RP,RQ:SG,SH:SM,SR:SS"), .Cells.Resize(Rows.Count - 1).Offset(1, 0)).ClearContents
End With

Operáciu mazania vykonáte naraz, len tú adresu oblasti rozdelíte na 2 reťazce, teda 2 Range, no naspäť spojené v Union, tak ako som ukázal.

A neviem, čo bude všetko to makro ešte robiť, ale Select nemusíte použiť vôbec, ani tie Scroll. Ideálne by bolo aj označenie listu, aby nedošlo k spusteniu makra na inom liste. Stačí teda iba:
With Worksheets("nazov listu")
Union(.Range("prvá polka textu adresy"), .Range("druhá polka textu adresy")).ClearContents
End With

Dĺžka adresy môže byť maximálne veľkosť datového typu Byte, teda 0..255. Vaša adresa má 257 znakov.

Dajte si to na menšie kúsky a do Union
Union(Range("B2:B1048576,D2:F1048576,J2:J1048576,N2:Q1048576,DK2:DK1048576,DM2:DM1048576,DQ2:DU1048576,DV2:EB1048576,FK2:FN1048576,FP2:FP1048576"), _
Range("FS2:FS1048576,FU2:FY1048576,QM2:QP1048576,QQ2:QU1048576,QV2:RF1048576,RG2:RP1048576,RQ2:SG1048576,SH2:SM1048576,SR2:SS1048576")).Select

To je parádny nápad, ako obabrať obmedzenie celých čísel v RANDBETWEEN zároveň s ROUND a zároveň so zahrnutím limitných hodnôt

Ale nezabudnite ešte na "balast" - teda kontrolu. Či bolo zadané číslo, či nebol InputBox zrušený, pozor ak máte filtrované dáta - vtedy zisťovanie posledného riadku metódou "xlUp" nefunguje a treba použiť Find, no a nechce sa mi moc premýšľať, ale neviem či netreba pripočítať +0,1 niekde v "(Maximum - Minimum + 0,1)" aby bola dosiahnuteľná aj horná hranica, ...

Možno ešte jednoduchšie:
Sub zapisvzorec5()
Dim Radku As Long
Dim Minimum As String, Maximum As String

Minimum = Replace(InputBox("Zadej minimální hodnotu např: 5,7 "), ",", ".")
Maximum = Replace(InputBox("Zadej maximální hodnotu např: 7,2 "), ",", ".")

With Worksheets("vysledky")
Radku = .Cells(Rows.Count, "A").End(xlUp).Row - 1
.Range("B2").Resize(Radku).Value = Evaluate("=ROUND(RANDARRAY(" & Radku & ",1," & Minimum & "," & Maximum & ",FALSE),1)")
End With
End Sub

RandArray() by sa dalo použiť aj v tom cykle:
Sub zapisvzorec4()
Dim Radku As Long
Dim Minimum As Double, Maximum As Double
Dim R()

Minimum = Val(Replace(InputBox("Zadej minimální hodnotu např: 5,7 "), ",", "."))
Maximum = Val(Replace(InputBox("Zadej maximální hodnotu např: 7,2 "), ",", "."))

With Worksheets("vysledky")
Radku = .Cells(Rows.Count, "A").End(xlUp).Row - 1
R = WorksheetFunction.RandArray(Radku, 1, Minimum, Maximum, False)

For i = 1 To Radku
R(i, 1) = Round(R(i, 1), 1)
Next i

.Range("B2").Resize(Radku).Value = R
End With
End Sub

Minimum = Replace(InputBox("Zadej minimální hodnotu např: 5,7 "), ",", ".")
Maximum = Replace(InputBox("Zadej maximální hodnotu např: 7,2 "), ",", ".")

Range("B2", Cells(Rows.Count, "A").End(xlUp).Offset(0, 1)).Formula = "=ROUND(" & Minimum & "+RAND()*(" & Maximum & "-" & Minimum & "),1)"

EDIT:
A hotové čísla:
Sub zapisvzorec3()
Dim Radku As Long
Dim Minimum As Double, Maximum As Double
Dim R() As Double

Minimum = Val(Replace(InputBox("Zadej minimální hodnotu např: 5,7 "), ",", "."))
Maximum = Val(Replace(InputBox("Zadej maximální hodnotu např: 7,2 "), ",", "."))

With Worksheets("vysledky")
Radku = .Cells(Rows.Count, "A").End(xlUp).Row - 1
ReDim R(1 To Radku, 1 To 1)

For i = 1 To Radku
R(i, 1) = Round(Minimum + Rnd() * (Maximum - Minimum), 1)
Next i

.Range("B2").Resize(Radku).Value = R
End With
End Sub

Slovné spojenie "vymyslene seriove cislo" je skoro ako oxymoron. Sériové čísla sú totiž vždy systémové - poskladané na základe nejakých pravidiel, a nie náhodne vymyslené.

Možno skúste priložiť prílohu, pre lepšie pochopenie sa.

Nikdy ma nenapadlo skúmať, či má Selection vlastnosť ListObject. Nová infoška, dík. Zaujímavosťou je, že to nie je ListObjects, ale ListObject. Teda ak vyberiem 2 Tabuľky, ListObject je iba tá prvá.

Skrátene ide napísať aj verzia s Intersect, ale nie tak krátko ako Vaša verzia:
On Error Resume Next
With Worksheets("Hárok1").ListObjects("Tabulka")
MsgBox Intersect(Selection, .DataBodyRange).Row - .Range.Row
End With

Každopádne tak či tak strácame info o konkrétnej chybe. Treba sa rozhodnúť či je toto info potrebné.

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse