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

Příspěvky uživatele

Je to Worksheet_Change, teda udalosť listu. Takže to musí ísť do modulu daného listu (u Vás je to "List1 (Hárok1)"), nie do normálneho modulu.
EDIT:
A ešte, ak máte pevnú zložku, tak nemôžete použiť to, čo tam máte
Zlozka = ThisWorkbook.Path & "C:\Users\Lucka\OneDrive\Počítač\MO\Excel revizie upozornovanie\Revizie dokumenty\"
ale musí to byť bez toho "ThisWorkbook.Path"
Zlozka = "C:\Users\Lucka\OneDrive\Počítač\MO\Excel revizie upozornovanie\Revizie dokumenty\"
Lebo s tým, vlastne zreťazíte 2 cesty. Cestu k aktuálnemu súboru a cestu manuálne zadanú v reťazci. A vtedy Vám to nebude fachať, čo je jasné.

Prípadne prvý riadok kódu upravte na
Set Zmena = Intersect(ListObjects("Tabuľka1").DataBodyRange.Columns(3), Target)
a bude to kontrolovať iba 3 stĺpec objektu Tabuľka1, a nie celý stĺpec C.

Formátovanie, zlúčené bunky a pod, to jedine makrom, a to tak, že pri aktivácii daného súhrnného listu by prebehla aktualizácia. Inak to možné nie je. Vložte prílohu s pár listami, pár riadkami dát, a manuálne vytvorený požadovaný výsledok. Nech je jasné, či sú listy rovnakej šírky, či sa ku každému listu kopíruje aj jeho hlavičkový riadok alebo sú rovnaké, a množstvo iných vecí. Proste manuálne vyrobte požadovaný vzor a makro prispôsobíme...

Function EVAL_WORKDAY(Datum As Date, Dni As Long) As Date
Dim Rok As Long
Rok = Year(Datum)
EVAL_WORKDAY = Evaluate("=WORKDAY(" & CDbl(Datum) & "," & Dni & ",DATEVALUE(MID(SUBSTITUTE(""01/01*""&TEXT(DOLLAR((""4/""&" & Rok & ")/7+MOD(19*MOD(" & Rok & ",19)-7,30)*14%,)*7-5,""mm/dd"")&""*05/01*05/08*07/05*07/06*09/28*10/28*11/17*12/24*12/25*12/26*"",""*"",""/""&" & Rok & "),(ROW(1:12)-1)*10+1,10)))")
End Function

Ak sú nejaké premenné definované ako objekty, je programátorsky "čisté" ich zrušiť. VBA si takéto obyčajné objekty zruší samozrejme sama po skončení procedúry. Ale pre začiatočníka, je vhodne sa naučiť objekty vždy rušiť. Ono totiž objekt nemusí byť len FSO, ale aj niečo podstatne väčšie a zložitejšie, napr. taká aplikácia. Čo ak bude objektom skrytá inštancia Excelu, Outlooku, ... Tá zostane visieť na systémových prostriedkoch aj po zatvorení Excelu. Aplikácie sa ešte navyše musia najskôr zatvoriť. Krízovo sa zrovna aplikácie sa dajú zrušiť potom v Správcovi úloh, ale iný objekt nemusí.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Bunka As Range, Zlozka As String, Subor As String
Set Zmena = Intersect(Columns(3), Target)
If Not Zmena Is Nothing Then
Zlozka = ThisWorkbook.Path & "\Revizie dokumenty\"
Application.EnableEvents = False
Application.ScreenUpdating = False
For Each Are In Zmena.Areas
For Each Bunka In Are.Cells
Subor = Bunka.Value
Subor = Subor & IIf(Right$(Subor, 5) = ".docx", "", ".docx")
If LenB(Subor) = 5 Or Len(Dir(Zlozka & Subor, vbNormal)) = 0 Then
Bunka.Hyperlinks.Delete
Else
Bunka.Value = Subor
Bunka.Hyperlinks.Add Anchor:=Bunka, Address:=Zlozka & Subor, TextToDisplay:=Subor, ScreenTip:=Subor
End If
Next Bunka
Next Are
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub

Dajte Break na riadok s Kill...
Nastavte, aby to odoslalo mail na nejakú Vašu skúšobnú adresu (ja som použil zoznam.sk).
Makro stopnite.
Zostane Vám uložený súbor v tempe.
Stiahnite si prílohu zo skúšobného mailu.
Porovnajte súbor z mailu s tým čo je v tempe.

Mne to totiž funguje aj v tejto Vašej verzii.

Prípadne krokujte makro, a zistite, kedy sa odkaz zmení. Skúsil by som najskôr stopku na
Application.CutCopyMode = False
a
.SaveAs TempFilePath...

A uveďte ešte verziu Office.

Ako píšem, všetko sa dá vylepšovať. Tak napr.
oFSO.CopyFile oFile.Path, sTargetPath & aNewNames(i, 1), True
tretí parameter True určuje, že existujúci súbor v cieli bude prepísaný. Chyba nastane, napr. ak ten súbor, ktorý sa má prepísať, bude otvorený v prehrávači a hrať. Alebo ak neexistuje cieľový adresár, lebo test na existenciu nerobíme. Alebo to budete ukladať na kľúč, ktorý tam nebude či ho počas kopírovania vytiahnete. Alebo nový názov bude obsahovať nedovolené znaky ... Možností sú mraky.

Úprava by mohla byť napr. takáto:
Sub kopirovanie_a_premenovanie()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim aNewNames()
Dim aOldNames()
Dim CountFiles As Long
Dim sPath As String
Dim sSourcePath As String
Dim sTargetPath As String

Const SOURCE_SUBPATH = "songy"
Const TARGET_SUBPATH = "fffffff"

sPath = ThisWorkbook.Path & "\"
sSourcePath = sPath & SOURCE_SUBPATH & "\"
sTargetPath = sPath & TARGET_SUBPATH & "\"

Set oFSO = CreateObject("Scripting.FileSystemObject")

If Len(Dir(sSourcePath, vbDirectory)) = 0 Then MsgBox "Zdrojová zložka neexistuje." & vbNewLine & sSourcePath: GoTo KONIEC
If Len(Dir(sTargetPath, vbDirectory)) = 0 Then
If MsgBox("Cieľová zložka neexistuje. Chcete ju vytvoriť ?" & vbNewLine & sTargetPath, vbQuestion + vbYesNo) = vbYes Then
If Not CreateDirStruct(oFSO, sTargetPath) Then MsgBox "Cieľovú zložku nie je možné vytvoriť." & vbNewLine & sTargetPath, vbCritical: GoTo KONIEC
Else
GoTo KONIEC
End If
End If

Set oFolder = oFSO.GetFolder(sSourcePath)
CountFiles = oFolder.Files.Count

With ThisWorkbook.Worksheets("Hárok1")
Select Case CountFiles
Case 0: MsgBox "Žiadne súbory v zložke" & vbNewLine & sSourcePath: GoTo KONIEC
Case 1: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames(1, 1) = .Cells(3, 2).Value
Case Else: aNewNames = .Cells(3, 2).Resize(CountFiles).Value
End Select
aOldNames = aNewNames


On Error Resume Next
For Each oFile In oFolder.Files
i = i + 1
Application.StatusBar = i & " / " & CountFiles
aOldNames(i, 1) = oFile.Name
oFSO.CopyFile oFile.Path, sTargetPath & aNewNames(i, 1), True
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR " & aOldNames(i, 1): Err.Clear
Next oFile
On Error GoTo 0

.Cells(3, 3).Resize(CountFiles).Value = aOldNames
End With

Application.StatusBar = False
KONIEC:
Set oFolder = Nothing: Set oFSO = Nothing: Set oFile = Nothing
End Sub

Function CreateDirStruct(ByRef oFSO As Object, ByVal sPath As String) As Boolean
Dim aP() As String, aD() As String, i As Byte

sPath = sPath & IIf(Right$(sPath, 1) = "\", "", "\")
aP = Split(sPath, ":\")
aD = Split(aP(1), "\")

sPath = aP(0) & ":"
On Error GoTo END_CREATE
For i = 0 To UBound(aD) - 1
sPath = sPath & "\" & aD(i)
If Len(Dir(sPath, vbDirectory)) = 0 Then oFSO.CreateFolder sPath
Next i
END_CREATE:
CreateDirStruct = Err.Number = 0
End Function
Vyskúšajte, lebo všetko som netestoval, len napísal.

Dokonalé určo nie. Teraz som na to pozrel, a hneď vidím jednu vec na ktorú som myslel, ale zabudol ju tam dopísať:
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR": Err.Clear
má byť
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR " & aOldNames(i, 1): Err.Clear
aby tam napísalo aj názov súboru, pri ktorom nastala chyba.

ďalej v tomto riadku
Case Else: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames = .Cells(3, 2).Resize(CountFiles).Value
je ten ReDim zbytočný
Case Else: aNewNames = .Cells(3, 2).Resize(CountFiles).Value

no a programátorsky čisto by malo byť, že ak už máme vytvorené objekty, a vyskakujeme z procedúry, mali by sme objekty zrušiť. Teda pred tento riadok
Set oFolder = Nothing: Set oFSO = Nothing
si pridáme KONIEC:
KONIEC:
Set oFolder = Nothing: Set oFSO = Nothing
a následne budeme vyskakovať z procedúry nie takto
Case 0: MsgBox "Žiadne súbory v složke" & vbNewLine & sSourcePath: Exit Sub
ale takto
Case 0: MsgBox "Žiadne súbory v složke" & vbNewLine & sSourcePath: GoTo KONIEC
a to som ešte zabudol prihodiť na konci objekt súboru
Set oFolder = Nothing: Set oFSO = Nothing
-->
Set oFolder = Nothing: Set oFSO = Nothing: Set oFile = Nothing
Vždy je čo zlepšovať...

Skúste toto
=SUMPRODUCT((COUNTIF(OFFSET(Table_0[Datum];;;ROW(Table_0[Datum])-1);Table_0[Datum])=1)*(Table_0[Technik]=$F$3)*(Table_0[Datum]>=$D5)*(Table_0[Datum]<=$E5))
=SOUČIN.SKALÁRNÍ((COUNTIF(POSUN(Table_0[Datum];;;ŘÁDEK(Table_0[Datum])-1);Table_0[Datum])=1)*(Table_0[Technik]=$F$3)*(Table_0[Datum]>=$D5)*(Table_0[Datum]<=$E5))

Ohľadom premenovania skúste pozrieť, ako som to robil tu.
EDIT:
Pr.
Sub kopirovanie_a_premenovanie()

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim i As Integer
Dim aNewNames()
Dim aOldNames()
Dim CountFiles As Long
Dim sPath As String
Dim sSourcePath As String
Dim sTargetPath As String

Const SOURCE_SUBPATH = "songy"
Const TARGET_SUBPATH = "fffffff"

sPath = ThisWorkbook.Path & "\"
sSourcePath = sPath & SOURCE_SUBPATH & "\"
sTargetPath = sPath & TARGET_SUBPATH & "\"

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(sSourcePath)
CountFiles = oFolder.Files.Count

With ThisWorkbook.Worksheets("Hárok1")
Select Case CountFiles
Case 0: MsgBox "Žiadne súbory v složke" & vbNewLine & sSourcePath: Exit Sub
Case 1: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames(1, 1) = .Cells(3, 2).Value
Case Else: ReDim aNewNames(1 To CountFiles, 1 To 1): aNewNames = .Cells(3, 2).Resize(CountFiles).Value
End Select
aOldNames = aNewNames

On Error Resume Next
For Each oFile In oFolder.Files
i = i + 1
aOldNames(i, 1) = oFile.Name
oFSO.CopyFile oFile.Path, sTargetPath & aNewNames(i, 1), True
If Err.Number <> 0 Then aOldNames(i, 1) = "ERROR": Err.Clear
Next oFile
On Error GoTo 0

.Cells(3, 3).Resize(CountFiles).Value = aOldNames
End With

Set oFolder = Nothing: Set oFSO = Nothing
End Sub

Vôbec som nepojal čo chcete. Ale tie položky bez údajov si zapnite v možnostiach daného poľa, je tam "Zahrnúť položky neobsahujúce údaje" alebo tak nejak sa to volá.
Inak zase platí, ak požadujete nejakú formu výsledku, normálne ju manuálne vytvorte, nakopírujte, napíšte. Nech ten čo Vám pomáha, vidí čo chcete. Ono je to z textového popisu často ťažko vydedukovať. Ako je to staré známe "Obrázok povie viac ako 1000 slov" ...

Zle!
Skúsim za Vás.
Takže, hovorím pravdu ak poviem takýto popis ?

Ešte tu pracujem s variantom automatického vymieňania referencie na Outlook podľa aktuálnej verzie, priamo za behu kódu. Čo mi funguje v E2019, ale v E2010 mi nejde nefunkčná referencia zmazať. Skúsim ešte poriešiť.

Aj ste si to po sebe prečítal? A pochopil? Zošit nieje list. Navyše list Data tam neexistuje, ale volá sa Zdroj.
"Ak dám zadávať posledné číslo..."??? tiež nechápem.
Pridajte prílohu, kde manuálne vyrobte kompletný požadovaný výsledok z dát, ktoré v nej sú.
A pridajte trošku logickejší popis.
No a čo sa týka tej čiary, aj keď neviem ešte presne čo chcete, každopádne sa vzorcom nedá zistiť kde je čiara orámovania.

Uživatelské menu

Nejste přihlášen(a)

• přihlásit
• registrace

\n

Menu

On-line nástroje

Formulář Faktura

Aktivní diskuse