Příspěvky uživatele
< návrat zpět
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 ?
Do tabuľky na liste Predná, potrebujem zapísať všetky čísla z poslednej ohraničenej oblasti zo stĺpca K na liste Zdroj. A to tak, že začnem v E12 postupujem dole po E18, a následne na ďalší stĺpec od F12 ... pokiaľ neminiem všetky čísla z poslednej ohraničenej skupiny.
Ak je to tak, tak vzorcom jedine, ak aktuálnu skupinu označíte nejak inak, tu vedľa písmenko "a". Ak naozaj iba orámovaním, tak jedine makrom.
(maticový vzorec)
=IFERROR(INDEX(Zdroj!$K:$K;SMALL(IF(OFFSET(Zdroj!$L$2;;;COUNTA(Zdroj!$K:$K))="a";ROW(OFFSET(Zdroj!$L$2;;;COUNTA(Zdroj!$K:$K))));ROW(A1)+(COLUMN(A1)-1)*7));"")
=IFERROR(INDEX(Zdroj!$K:$K;SMALL(KDYŽ(POSUN(Zdroj!$L$2;;;POČET2(Zdroj!$K:$K))="a";ŘÁDEK(POSUN(Zdroj!$L$2;;;POČET2(Zdroj!$K:$K))));ŘÁDEK(A1)+(SLOUPEC(A1)-1)*7));"")
Chcel som od Vás manuálne vytvorený príklad výsledku. A Váš popis spomína 2 čísla, no vo výsledku je jedno číslo dva krát !!!
EDIT: Prípadne UDF funkcia na zistenie oblasti
do modulu
Public Function POSL_ORAM_SKUPINA() As Range
Dim LR As Long, i As Long, Kon As Long, Zac As Long
Application.Volatile
With Worksheets("Zdroj")
LR = .Cells(Rows.Count, "K").End(xlUp).Row
For i = LR To 2 Step -1
If Kon = 0 Then
If .Cells(i, "K").Borders(xlBottom).ColorIndex <> -4142 Then Kon = i
Else
If .Cells(i, "K").Borders(xlTop).ColorIndex <> -4142 Then Zac = i: Exit For
End If
Next i
If Kon <> 0 And Zac <> 0 Then Set POSL_ORAM_SKUPINA = .Range(.Cells(Zac, "K"), .Cells(Kon, "K"))
End With
End Function
vzorec do oblasti (maticový vzorec)
=IFERROR(INDEX(Zdroj!$K:$K;SMALL(ROW(POSL_ORAM_SKUPINA());ROW(A1)+(COLUMN(A1)-1)*7));"")
a do modulu listu
Private Sub Worksheet_Activate()
Calculate
End Sub
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.
Problém je Referencia. Je to napísané hneď v prvom riadku
' Přidat Tools - References - Microsoft Outlook xx.x Object Library
To "xx.x" znamená Vašu verziu! Ja mám Office 2019, teda číslo verzie je 16.0. Vy máte Office 2010, a číslo verzie je 14.0.
Ak sa pozriete do Referencií, uvidíte tam MISSING na verzii 16.0. Tak ju odčiarknite, potvrďte. Potom začiarknite Vašu 14.0 a potvrďte. Chyba s Right$ je len nejaká divná sprievodná reakcia na tú referenciu. Ak opravíte Referenciu, Right$ aj Right bude fungovať.
Tak skúste, ale nechcite ten vzorec vysvetľovať. Teraz je to na 3 mená s rovnakým SJM a LV. Ľahko sa pridá 4. či 5. iba pridaním na koniec vzorca
&IFERROR(" a "&INDEX(JMENO;SMALL(IDENTICAL;3));"")
akurát, že to číslo 3 bude 4 atď. Neviem na koľko to je riadkov ale vypočtovo to bude náročné.
Odstráňte ten znak $ za "Right". Nie som si istý, či to Vaša verzia Excelu pozná. V novších to bežne používam. Akú máte verziu?
Takže máte v liste data na 5 strán na výšku.
Chcete tlačiť až od 3 strany, a to tak, že:
1. vytlačená strana (v liste je to strana 3.) bude mať 1/3.
2. vytlačená strana (v liste je to strana 4.) bude mať 2/3.
3. vytlačená strana (v liste je to strana 5.) bude mať 3/3.
To je to čo chcete?
VPageBreaks.Count
zmente na
ActiveSheet.VPageBreaks.Count
A čo myslíte tým výpočtom? Vzorec? To nejde. Musíte si výpočet urobiť buď vzorcom alebo vo VBA a do hlavičky dať výsledok.
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