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

Příspěvky uživatele

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

Pr.
Sub KtoryRiadokTabulky()
Dim XSelect As Range

With ThisWorkbook.Worksheets("Hárok1")
If Selection.Parent.Name = .Name Then
If TypeName(Selection) = "Range" Then
With .ListObjects("Tabulka")
Set XSelect = Intersect(Selection, .DataBodyRange)
If Not XSelect Is Nothing Then
MsgBox "Výber začína na riadku " & XSelect.Row - .Range.Row, vbInformation
Else
MsgBox "Výber sa neprelína s objektom " & .Name, vbExclamation
End If
End With
Else
MsgBox "Nie je vybraná oblasť, ale " & TypeName(Selection), vbExclamation
End If
Else
MsgBox "Spúšťate makro na inom liste ako " & .Name, vbExclamation
End If
End With
End Sub

EDIT: Ešte som pridal ošetrenie prípadu, ak nie je vybraná žiadna oblasť, ale napr. ovládací prvok, graf, či obrázok ... vyvolalo by to totiž chybu.
Aspoň je pekne vidieť, ako funguje programovanie, že pre 1 funkčný riadok treba myslieť a ošetriť množstvo možných stavov, ktoré by mohli nastať. A to tam ešte nie je zakomponované ošetrenie neexistencie požadovaného listu a neexistencie Tabuľky "Tabulka".

V tom prípade som Vás pochopil správne, a obe verzie Vám budú fungovať.

A ešte ma napadlo použiť Class s Events a dosiahnuť tým možnosť zafarbenia volieb.

Nejako som ten popis nepobral.
Na jednom hlasovacom lístku máte X kandidátov. A pri každom kandidátovi môžete zaškrtnúť Áno/Nie/Zdržal. Doslovne pri každom - naraz. Naraz ? A ako potom vyhodnocujete kto je zvolený? Ak môže vzniknúť mrte možností kombinácií. Niekto zvoli ANO pre k1, k2 a NIE pre k3. Iný zvolí NIE pre k1 a ANO pre k3 no pri k2 sa zdrží. Ďalší dá 3x NIE, ...
Ak toto preklenieme, tak potom po vyplnení formulára (odpísaní papierového lístku ???) sa potom prevedie zápis tlačítkom?

Pozor oprava, mrk vyššie.

Stačí teda v 1. riadku urobiť takúto zmenu
Set rZmena = Application.Intersect(Range(Range("W4"), Cells(Rows.Count, "N").End(xlUp)), Target) 'kontrola změny v dané oblasti
a vyplnenosť dát/riadkov by som určo robil pomocou kontroly posledného údaju v "N", lebo práve "N" hodnota sa bude potom vyhľadávať.

Ak myslíte niečo iné pod výrazom "pokud je řádek na Listu2 prázdný", viac to špecifikujte.

EDIT:
Oprava, musí to byť napr. takto
Set rZmena = Application.Intersect(Range(Range("W4"), Cells(Cells(Rows.Count, "N").End(xlUp).Row, "W")), Target) 'kontrola změny v dané oblasti
Inak by to reagovalo od stĺpca N po stĺpec W. Som sa "upsal"

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse