Příspěvky uživatele
< návrat zpět
Biely text na bielom pozadí ???
Takže netreba nič. Premýšľal som na ADO, cez ktoré sa dá relatívne rýchlo získať zoznam listov, a na tie by sa dal aplikovať SUMPRODUCT s kontrolou oblasti na výskyt (v zatvorenom zošite). Ale práve tá oblasť je problém. Možno by to šlo cez ADO zistiť. Potom by sa tie vzorce naraz zapísali do pomocných buniek a máte celkom rýchlo výsledok. Lenže toto by asi bolo skôr na PowerQuery, kde netreba riešiť oblasti, lenže treba čarovať zase s názvami stĺpcov...
Neuviedol ste ani či hľadať v celom liste alebo iba v jednom stĺpci. Ani či sú súbory a listy rovnaké alebo rôznorodé.
Nápady by boli, hneď 2, ale príliš sa mi do toho nechce. Tak snáď ste si pomohol v TC.
Ten vzorec ale nemáte správne prerobený. Namiesto bodkočiarok (středníků) musia byť v EN verzii čiarky.
Vkladajte EN verzie vzorcov a bude to fungovať. Takto pochybujem, lebo pre neho bude FormulaLocal po EN pre Vás CZ. Ale keď to budete vkladať po EN, tak to pôjde obom.
Ako je to s listami v súboroch? Je len 1 list rovnakého mena?
A v ktorom stĺpci sa má hľadať?
Veď to je plne dynamické. Som počítal, že si to upravíte ako ste vravel.
Takže príklad (dá sa napchať aj do 1 riadku):
Sub pokus()
Dim R As Long, PR As Long, PS As Integer, S As Integer, ADR As String
R = 10 'prvý riadok
S = 4 'prvý stĺpec
PR = 200 'počet riadkov
PS = 1 'počet stĺpcov
ADR = Cells(R, S).Resize(PR, PS).Address 'Adresa
Range(ADR).Value = Evaluate(Replace("=IF(?<>"""",ROUND(?,2),"""")", "?", ADR)) 'Vo vzorci sa za ? nahradí adresa
End Sub
EDIT:
Prípadne by som to upravil ešte pomocou IFERROR, pre prípad, že by tam bol aj text:
Range(ADR).Value = Evaluate(Replace("=IFERROR(IF(?<>"""",ROUND(?,2),""""),?)", "?", ADR)) 'Vo vzorci sa za ? nahradí adresa
Range("D10:D200").Value = Evaluate("=IF($D$10:$D$200<>"""",ROUND($D$10:$D$200,2),"""")")
Tak testujte o 1 podmienku menej. Ak to dobre chápem, tak stačí otestovať či je I1 v tom inom zošite číslo a zároveň ak je, tak či je väčšie ako P2 a aktuálnom liste aktuálneho zošitu. Ak je splnená táto dvojpodmienka tak hodnotu I1 v inom zošite nahradiť tou z P2 z aktuálneho listu aktuálneho zošitu. Ale nahradí to aj keď bude I1 obsahovať "abc" alebo iný text ako "Nejsou data", teda akýkoľvek. Neviem, čo môže I1 nadobúdať.
Sub pokus()
Dim JmenoS As String, Rok As String, Nahradna As Double, Hodnota
JmenoS = "Zošit1"
Rok = "Hárok1"
Nahradna = Range("P2").Value
With Workbooks(JmenoS).Worksheets(Rok).Range("I1")
Hodnota = .Value
If IsNumeric(Hodnota) And Hodnota > Nahradna Then MsgBox "kuk" Else .Value = Nahradna
End With
End Sub
Ale máte pravdu v tom, že sa tým netreba zaoberať, či ide o 1 alebo 2/1000 sek je šumák. To len tak z nudy... 
Myslíte test, či v bunke je text "Nejsou data", alebo chcete otestovať či je bunka prázdna niečim podobným:
IsEmpty(Workbooks(JmenoS).Worksheets(Rok).Range("I1"))
LenB(Workbooks(JmenoS).Worksheets(Rok).Range("I1"))=0
Workbooks(JmenoS).Worksheets(Rok).Range("I1").Value=""
Tag je vlastnosť niektorých objektov, a dá sa použiť práve v takomto prípade, ak chcete preniesť nejakú hodnotu cez stály objekt medzi procedúrami. Použil som to z minimalistického hľadiska, namiesto globálnej premennej.
Ostatné veci sú len úpravy Vašeho kódu, napr. kontrola objektu Outlook (načo vytvárať ďalší, keď je spustený), odchyt chyby pri otváraní obrázku, či odoslaní mailu. No a dal som tam ten spomínaný zápis cez pole, naraz. Ak by som vedel čo je v stĺpcoch 9 a 10, možno by sa dalo to celé urobiť naraz aj s cestou k obrázku. Inak hyperlink je jednoduchý, namiesto
.Cells(FirstEmptyRow, 11).Value = Image1.Tag
dajte
If LenB(Image1.Tag) > 0 Then
.Cells(FirstEmptyRow, 11).Value = Image1.Tag
.Hyperlinks.Add Anchor:=.Cells(FirstEmptyRow, 11), Address:=Image1.Tag
End If
Doplnené do predošlého príspevku s kódom a aj v prílohe.
Príklad úpravy
Private Sub cmbNahratFoto_Click()
Dim ImageLocation As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Images", "*.bmp; *.jpg; *.jepg; *.png; *.tif", 1
If .Show = -1 Then ImageLocation = .SelectedItems(1)
End With
If ImageLocation <> "" Then
With Image1
.Tag = ImageLocation
On Error GoTo ERROR
.Picture = LoadPicture(ImageLocation)
.PictureSizeMode = fmPictureSizeModeStretch
End With
End If
Exit Sub
ERROR:
MsgBox "Při načítání obrázku došlo k chybě !", vbExclamation
End Sub
Private Sub btZapisTPM_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim FirstEmptyRow As Long
Dim aZapis(7)
Const PW As String = "heslo"
'Nastavení pole zápisu hodnot
aZapis(2) = Now
aZapis(3) = Application.UserName
aZapis(4) = txbPopisZavady.Text
aZapis(5) = cbxZodpovednost.Text
aZapis(6) = cbxMisto.Text
aZapis(7) = cbxPatro.Text
With ThisWorkbook.Worksheets("TPM")
FirstEmptyRow = .Cells(Rows.Count, 2).End(xlUp).Row + 1
aZapis(0) = .Cells(FirstEmptyRow - 1, 1).Value
If IsNumeric(aZapis(0)) Then aZapis(0) = aZapis(0) + 1 Else aZapis(0) = 1
aZapis(1) = .Cells(FirstEmptyRow - 1, 2).Value
If IsNumeric(aZapis(1)) Then aZapis(1) = aZapis(1) + 1 Else aZapis(1) = 1
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
.Unprotect PW
ThisWorkbook.Unprotect PW
'Zápis hodnot
.Cells(FirstEmptyRow, 1).Resize(, 8).Value = aZapis
If LenB(Image1.Tag) > 0 Then
.Cells(FirstEmptyRow, 11).Value = Image1.Tag
.Hyperlinks.Add Anchor:=.Cells(FirstEmptyRow, 11), Address:=Image1.Tag
End If
.Protect PW
ThisWorkbook.Protect PW
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End With
Unload TPM
''EMAIL
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
Err.Clear
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
If cbxZodpovednost = "Údržba" Then
.to = "email"
ElseIf cbxZodpovednost = "Správce budov" Then
.to = "email"
End If
.CC = ""
.BCC = ""
.Subject = "Nové TPM"
.Body = "Máte nové TPM - pro přehled všech TPM navštivte adresu"
.Attachments.Add ThisWorkbook.FullName
.Send 'or use .Display
End With
If Err.Number <> 0 Then MsgBox "Chyba pri vytváření mailu.", vbExclamation
On Error GoTo 0
Set OutMail = Nothing: Set OutApp = Nothing
End Sub
Veď predsa tú cestu k obrázku musíte mať v nejakej premennej, veď ju načítavate cez LoadPicture(cesta) do Image1. No tak tú premennú uložte. Akú inú cestu k obrázku potrebujete, ako tú, čo už máte. Vytvorte si vo Forme globálnu premennú a do nej uložte cestu k obrázku v procedúre toho načítavacieho buttonu, a potom túto globálnu premennú s cestou budete mať dostupnú aj procedúre ukladacieho buttonu.
Približne takto
Dim Cesta As String
Private Sub btnNahratFotografii_Click()
Cesta = "d:\Dokumenty\Obrázky\Avatar01.jpg"
Image1.Picture = LoadPicture(Cesta)
End Sub
Private Sub btnZapisTPM_Click()
wsDB.Cells(2, 11).Value = Cesta
End Sub
Ak tam potrebujete zároveň zapísať aj zodpovednosť, popis závady a ostatné do jedného riadku v DB, tak to cez pole pôjde na šupu. Ak ten Form máte otvorený na zápis viac ako 1 položky, tak pri vytváraní novej vynulujte premennú Cesta, a to preto, ak by mohla nastať aj situácia, že obrázok nebude vložený. Lebo by sa vložila pôvodná cesta.
Aj nematicovo:
=SUMPRODUCT(1/COUNTIF(A1:A6;A1:A6))
=SOUČIN.SKALÁRNÍ(1/COUNTIF(A1:A6;A1:A6))
prípadne cez FREQUENCY
=SUMPRODUCT(--(FREQUENCY(A1:A7;A1:A7)>0))
=SOUČIN.SKALÁRNÍ(--(ČETNOSTI(A1:A7;A1:A7)>0))
všetko z prvého odkazu na Google.
Tak nejak som tušil, že si to všimnete 
Môže tam byť aj
"<>"
Ide len o to nejako to podmieniť, lebo maticové vzorce často treba podmienkou prinútiť k "zmaticoveniu".
Napr.: (maticový vzorec : Ctrl+Shift+Enter)
=MATCH(TRUE;SUMIF(OFFSET(C3;;;;COLUMN(C3:L3)-2);"<>somarina")>=A3;0)
=POZVYHLEDAT(PRAVDA;SUMIF(POSUN(C3;;;;SLOUPEC(C3:L3)-2);"<>somarina")>=A3;0)
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články