Příspěvky uživatele
< návrat zpět
No tak skúste toto, Jednouché to veru nieje.
Pr.
-Tá šablóna musí byť externá (iný súbor na disku) ? Alebo môže byť súčasťou tohto zošitu ?
-Makro sa bude spúšťať z iného zošitu, a v tomto sa budú pridávať iba listy, ale inak bude tento súbor bez makra ? Alebo bude makro v tomto zošite ?
-Môže nastať, že bude treba zapísať viac riadkov ako 31 (toľko má šablóna riadkov v častiach 5,6,7) ? Alebo aj v iných častiach či môže nastať "pretečenie" ? Čo v takom prípade ?
-Časti 1,2,3,4,8,9 sú vždy jednočlenné, alebo môžu byť viacčlenné ?
-Časti 1,2,3,4 vždy začínajú danú skupinu pre jeden list ? Teda sú vždy na prvom riadku skupiny ?
-Časti 8,9, sú vždy na konci skupiny ?
...
Domov - Úpravy - Vymazať - Vymazať formáty
Stiahnuť to ale veru nejde. Veľkosť 0.
s = Replace(s, "_", "", 1, 1)
Prečo by to nefungovalo ?
EDIT: Ešte prikladám aj súbor, kde je ukázaný príklad hromadného načítania aj zápisu, lebo po jednej bunke to robiť = pomalé.
Toto by malo fungovať...
Function ZoznamSuborov(Adresar As String) As Variant
Dim FSO As Object, Subor As Object, Zoznam() As String, Pocet As Long
On Error GoTo KONIEC
Set FSO = CreateObject("Scripting.FileSystemObject").GetFolder(Adresar)
On Error GoTo 0
Pocet = FSO.Files.Count
If Pocet > 0 Then
ReDim Zoznam(1 To Pocet)
Pocet = 0
For Each Subor In FSO.Files
Pocet = Pocet + 1
Zoznam(Pocet) = Subor.Name
Next Subor
ZoznamSuborov = Zoznam
End If
KONIEC:
Set FSO = Nothing: Set Subor = Nothing
End Function
Sub pokus()
Dim Vysledok
Vysledok = ZoznamSuborov("\\Elnino-pc\Download D\")
If IsArray(Vysledok) Then
ActiveSheet.Cells(1, 1).Resize(UBound(Vysledok)).Value2 = Application.Transpose(Vysledok)
Else
MsgBox ("Niesú žiadne súbory")
End If
End Sub
Private Sub Worksheet_Activate()
Worksheets("Hárok2").Cells(1, 1).Value = "Je zobrazený Hárok1"
End Sub
Private Sub Worksheet_Deactivate()
Worksheets("Hárok2").Cells(1, 1).Value = ""
End Sub
Pracovnú dobu môžete do konštanty zapísať ako Date:
Const PracDob1 = #8:00:00 AM#
alebo ako Double :
Const PracDob2 = 1 / 3
Sviatky môžete do poľa zadať :
Dim Svatky(), Rok As Long
Rok = Year(Date)
Svatky = Array(DateSerial(Rok, 1, 1), CDate(Evaluate("=(DOLLAR((""4/""&" & Rok & ")/7+MOD(19*MOD(" & Rok & ",19)-7,30)*14%,)*7-6)+1")), DateSerial(Rok, 5, 1), DateSerial(Rok, 5, 8), DateSerial(Rok, 7, 5), DateSerial(Rok, 7, 6), DateSerial(Rok, 9, 28), DateSerial(Rok, 10, 28), DateSerial(Rok, 11, 17), DateSerial(Rok, 12, 24), DateSerial(Rok, 12, 25), DateSerial(Rok, 12, 26))
ale ako pozerám na tému, tak na koniec ešte pridajte 1.1.Rok+1, ak by náhodou incident nastal na konci roka, treba počítať aj so sviatkom 1.1. následujúceho roku.
Detto by som doplnil aj pre ten vzorec od marjankaj. Označiť E4, vytvoriť Definovaný názov SVATKY:
=DATEVALUE(MID(SUBSTITUTE("01.01.XXXX"&TEXT((DOLLAR(("4/"&YEAR(List1!$C4))/7+MOD(19*MOD(YEAR(List1!$C4);19)-7;30)*14%;)*7-6)+1;"dd.mm.")&"XXXX01.05.XXXX08.05.XXXX05.07.XXXX06.07.XXXX28.09.XXXX28.10.XXXX17.11.XXXX24.12.XXXX25.12.XXXX26.12.XXXX01.01."&YEAR(List1!$C4+1);"XXXX";YEAR(List1!$C4));{1;11;21;31;41;51;61;71;81;91;101;111;121};10))
=DATUMHODN(ČÁST(DOSADIT("01.01.XXXX"&HODNOTA.NA.TEXT((KČ(("4/"&ROK(List1!$C4))/7+MOD(19*MOD(ROK(List1!$C4);19)-7;30)*14%;)*7-6)+1;"dd.mm.")&"XXXX01.05.XXXX08.05.XXXX05.07.XXXX06.07.XXXX28.09.XXXX28.10.XXXX17.11.XXXX24.12.XXXX25.12.XXXX26.12.XXXX01.01."&ROK(List1!$C4+1);"XXXX";ROK(List1!$C4));{1;11;21;31;41;51;61;71;81;91;101;111;121};10))
,ktorý bude počítaný automaticky pre každý riadok, teda incidenty môžu byť v rôznych rokoch. Inak by sa totiž pre predmetné roky museli robiť vždy samostatné stĺpce s dátumami pre daný rok.
A ten marjankaj-ov vzorec iba doplniť o tie počítané sviatky, čiže:
=WORKDAY(C4;INT((B4+D4*24)/8)-1;SVATKY)+MOD(B4+D4*24;8)/24+1/3
=WORKDAY(C4;CELÁ.ČÁST((B4+D4*24)/8)-1;SVATKY)+MOD(B4+D4*24;8)/24+1/3
Pr.
Ja som z tých podmienok trochu pomotaný, ale skúste toto. Uvádzam len ako príklad na to aby som ja pochopil logiku :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For i = 1 To 10
If InStr(Cells(i, 2).Value, "2018") > 0 Then
Cells(i, 3).Value = "OK"
Else
If InStr(Cells(i, 4), "cvt") > 0 Then
Cells(i, 2) = Cells(i, 2) & "/2018"
Cells(i, 3).Value = "OK"
Else
Cells(i, 3).Value = ""
End If
End If
Next i
End Sub
Každopádne, o koľko ide reálne dát ? Je nevhodné to robiť bunku po bunke na väčšom množstve dát - bude to pomalé. Navyše po každom označení bunky? To by bolo lepšie po každej zmene bunky, nie po označení, s tým že by sa na začiatok a koniec vypli/zapli Application.EnableEvents=False (True).
Ten cyklus má mať vždy 10 riadkov ?
OK sa má napísať vždy keď B obsahuje 2018, bez ohľadu na to či je v D hodnota "cvt" alebo nie ?
Šmarjá zase popis bez prílohy, a zase nejednoznačne pochopiteľný. Bez prílohy výstrel na slepo :
COUNTIF
SUMIF
MATCH / POZVYHLEDAT
VLOOKUP / SVYHLEDAT
Neviem ako presne kooperuje aplikačná vrstva kompilátoru VBA s OS a CPU, ale ak je tam skutočne nejaký tzv. špekulatívny výpočet (prediktívny), tak je slušná šanca, že to urobí aj za zobrazením Formulára, aj keď sa o tom nedozviete, ani keď si dáte Breakpoint. Treba vyskúšať, a ak to bude OK tak to bude asi kratšia cesta ako hľadať ťažko dostupné riešenie nepravidelného a ťažko odchytiteľného problému.
A kde v tomto vzorci niečo hľadáte ?
=VLOOKUP(B2;#ODKAZ!;4;FALSE)
=SVYHLEDAT(B2;#ODKAZ!;4;NEPRAVDA)
Ja keď si urobím pokusne nejakú zdrojovú tabuľku z Vašich dát, čo tam máte, tak mi to hľadá aj s "-" aj bez. Proste mi to nájde. Dajte reálnu prílohu bez odstránenej tabuľky na prehľadávanie, vzorkou reálnych (obdobných) dát, a v nepoškodenej prílohe.
Tento môj kód je na tú Vašu prvotnú prílohu (teraz je ešte v príspevku od Jiří497(18.2.2018 22:30) :
Private Sub Workbook_Open()
Dim Oblast As Range
Set Oblast = Range(Cells(1, 2), Cells(1, Columns.Count).End(xlToLeft))
On Error Resume Next
If Oblast.Offset(1, 0).Cells(1, WorksheetFunction.Match(CDbl(Date), Oblast, 0)).Value2 = 1 Then MsgBox "Pod dnešným dátumom je hodnota 1.", vbExclamation, "Upozornenie"
On Error GoTo 0
Set Oblast = Nothing
End Sub
Tento môj kód :
On Error Resume Next
x = WorksheetFunction.Match(CDbl(Date), Range("A1:AC1"), 0)
If Err > 0 Then MsgBox "Upoxornenie", vbExclamatoin
On Error GoTo 0
je reakcia na kód od Jiří497(20.2.2018 12:12) :
Sub pokus()
x = WorksheetFunction.Match(Date, Range("A1:AC1"), 0)
End Sub
No a takýto nejaký kód potrebujete na ten svoj posledný súbor (ktorý ste v prvom príspevku vymenila, nie ?):
Private Sub Workbook_Open()
Dim Riadkov As Long, arrStlpec()
With Worksheets("MK")
Riadkov = .Cells(Rows.Count, 2).End(xlUp).Row
ReDim arrStlpec(1 To Riadkov, 1 To 1)
If Riadkov = 1 Then arrStlpec(1, 1) = .Cells(1, 2).Value2 Else arrStlpec = .Cells(1, 2).Resize(Riadkov).Value2
On Error Resume Next
For i = 0 To Riadkov Step 7
If Month(arrStlpec(i + 1, 1)) = Month(Date) And Year(arrStlpec(i + 1, 1)) = Year(Date) Then
If .Cells(i + 2, 6 + WorksheetFunction.Match(CDbl(Date), .Range("G1:AH1").Offset(i, 0), 0)).Value2 = 1 Then MsgBox "Pod dnešným dátumom je hodnota 1.", vbExclamation, "Upozornenie"
Exit For
End If
Next i
On Error GoTo 0
End With
End Sub
Všetky som robil a skúšal v nejakom kontexte.
PS: Ešte poznámka k prehľadávanej oblasti v Match. Na ukážku v prvých kódoch sa ráta iba s jediným listom. V reále treba určiť list, tak ako som to urobil v poslednom kóde. Môže totiž nastať napr. to, že nebude list pri otváraní aktívny.
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