Příspěvky uživatele
< návrat zpět
Které by před kopírováním dat na jiný list omezilo oblast kopírovaných dat podle týdnu.
To je taká čarovná veta :)
Toto vyzerá ako ten výsledný list. Teda sem sú už dáta nakopírované z toho listu kde sa počítajú. A odtiaľ sa môžu kopírovať aj filtrované, čo môže meniť spôsob kopírovania. Celé kopírovanie neviem ako má fungovať, či by to náhodou nemohlo byť v jednom kroku z toho počítaného. Lebo takto to vyzerá, akoby ste chcel jedným krokom kopírovať dáta z počítacieho/filtrovacieho listu (ktorý berie dáta asi z ďalších listov), a druhým krokom z tejto kópie kopírovať vybraný rozsah týždňov na ďalší list (ktorý tu nie je, a neviem ako má vyzerať). Ideálne by bolo anonymizovať súbor, ponechať logiku, formáty, vzorce, filtre, zdrojový list/y, počítaný list, a požadovaný výsledok (hoci aj manuálne vytvorený).
Ak to má kopírovať makro, tak nie je potreba ani stĺpec "týden", to si dokáže makro vypočítať, či už po jednom cez WorksheetFunction alebo hromadne cez Evaluate. Stále pridávate tie texty "46 .týden", "47 .týden", ... Tie tam ale nie sú, tie tam predsa dopĺňame a zlučujeme s iným textom s menom.
Kopírovať vo Vašom slovníku znamená Copy+Paste alebo hodnota=hodnota?
Samotné makro väčšinou nie je problém napísať, ale pochopenie, o čo sa dotazovateľ snaží, často nevhodnou prílohou, popisom, otázkami, logikou dát a pod, to je často problém.
Samotné makro máte v prílohe, ale ak to nechcete mať rozkúskované, musíte mi pomôcť lepším podaním info.
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é.
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.
Uživatelské menu
\nMenu
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.
RSS nejnovější články