< návrat zpět

MS Excel

Téma: Kontrola existencie suboru v hociakom formate rss

Zaslal/a Durikam 5.9.2019 7:54

Urobil som makro:
Sub fileExistsFSORange()
Dim Rng As Range
Set fso_obj = CreateObject("Scripting.FileSystemObject")

Set Rng = Selection

For Each Cell In Rng
If fso_obj.fileExists(Cell) Then
Cell.Font.Color = vbGreen
Else
Cell.Font.Color = vbRed
End If
Next Cell
End Sub

takze ked do bunky napisem cestu suboru napr J:\zlozka\subor.pdf, a spustim makro tak mi overi ci existuje. Potreboval by som ale aby mi hladalo subory
bez zadefinovania formatu suboru. Skusal som J:\zlozka\subor.* ale to nefunguje.

Zaslat odpověď >
Strana:  1 2   další »
Durikam(5.9.2019 12:12)#044157
avatar
Predpokladam ze z bunky treba odstranit format suboru J:\zlozka\subor a v makre zadat "k bunke pridaj .* a hladaj vyraz" V makre by zastupny znak * asi mal fungovat. Meviete ako to napisat?citovat
JoKe(5.9.2019 12:34)#044161
avatar
For Each Cell In Rng

fileName = Cell & "*"
file = Dir(fileName)

If file = "" Then
Cell.Font.Color = vbRed
Else
Cell.Font.Color = vbGreen
End If
Next Cellcitovat
elninoslov(5.9.2019 12:39)#044162
elninoslov
JoKe: Zbežne na to pozerám, a pochybujem o funkčnosti podľa zadania. V bunke predsa bude názov aj s príponou. Ale hľadať má aj alternatívu, že bude mať súbor inú príponu. Musíte buď cez Left a InStrRev alebo Len+Split odstrániť príponu.

EDIT: Príklad:
Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, Cell As Range, V, Pos As Integer
For Each Cell In Selection.Cells
V = Cell.Value
Pos = InStrRev(V, ".")
If Len(Dir(Left$(V, IIf(Pos = 0, Len(V), Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
Next Cell
If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Sub

Sub AddColor(ByRef rngDest As Range, Cell As Range)
If rngDest Is Nothing Then Set rngDest = Cell Else Set rngDest = Union(rngDest, Cell)
End Subcitovat
Durikam(5.9.2019 13:52)#044175
avatar
@elninoslov Nemusi byt v bunke nazov aj s priponov. Ja ho tam teraz mam ale viem to prerobit aby v bunke pripona nebola. Funguje tvoje makro ale veeeelmi dlho kontroluje. cca 1 min 80 suborov. To co som daval ja, ked som musel mat presnu priponu tak to skontrolovalo za sekunducitovat
Durikam(5.9.2019 14:01)#044176
avatar
Funguju obidva, dik. Len neviem ci koli casu radsej nenarobit viac buniek v kazdej bude mat subor inu priponu a hladat to takto.citovat
Durikam(5.9.2019 14:12)#044177
avatar
Myslite ze by to urychlilo keby nehladalo akukolvek priponu ale zadafenovali sa len 3-4 mozne pripony?citovat
elninoslov(5.9.2019 14:45)#044179
elninoslov
No netuším čo s tým robíte, akú oblasť testujete, ale u mňa 100 súborov urobí za mrknutie oka. Rôzne druhy súborov XLSX, XLSM, MP3, ISO, JPG, TXT, TIB, FLAC, CSV, MP4, ... niekoľko vnorení adresárov, pomiešané 4 HDD ...

čo máte ako testovanú oblasť ? Snáď nie celý stĺpec ?

EDIT: Určite označujete celý stĺpec. Veď to je milión riadkov. Tak si namiesto Vašeho Selection dajte nejakú oblasť, alebo to aspoň najskôr vypodmienkujte, či to nieje prázdne

Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, Cell As Range, V, Pos As Integer
For Each Cell In Selection.Cells
V = Cell.Value
If Not IsEmpty(V) Then
Pos = InStrRev(V, ".")
If Len(Dir(Left$(V, IIf(Pos = 0, Len(V), Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
End If
Next Cell
If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Sub

alebo najlepšie checkujte iba prienik Vašeho výberu Selection s obsadenou časťou listu

Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, ARE As Range, Oblast As Range, Cell As Range, V, Pos As Integer
Set Oblast = Intersect(ActiveSheet.UsedRange, Selection)
If Oblast Is Nothing Then MsgBox "Žiadne data": Exit Sub

For Each ARE In Oblast.Areas
For Each Cell In ARE.Cells
V = Cell.Value
If Not IsEmpty(V) Then
Pos = InStrRev(V, ".")
If Len(Dir(Left$(V, IIf(Pos = 0, Len(V), Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
End If
Next Cell
Next ARE

If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Sub
2000 súborov mi to kontroluje asi 0,5 sekundy, a to pri označení celého stĺpca.citovat
Durikam(5.9.2019 15:04)#044181
avatar
Hladam len potrebny pocet buniek, len tych 80 buniek. Prehladava server. Mozno Server to brzdi ale ked som hladal konkretne subory s konkretnou priponou tak to bolo rychlocitovat
Durikam(5.9.2019 15:22)#044182
avatar
Takze odskusane, spomaluje to server. V PC to naslo rychlo.citovat
elninoslov(5.9.2019 15:56)#044184
elninoslov
Ešte som urobil úpravu, aby v prípade, že nebude uvedená prípona a zároveň nadradený adresár bude obsahovať bodku, nepovažoval aj časť názvu adresára za príponu. Teraz je fuk, či máte názvy s príponou, bez, aj či je v názve adresára bodka.
Sub CheckExists()
Dim rngRed As Range, rngGreen As Range, ARE As Range, Oblast As Range, Cell As Range, V, Pos As Integer, tmp() As String, Nazov As String, Separator As String

Set Oblast = Intersect(ActiveSheet.UsedRange, Selection)
If Oblast Is Nothing Then MsgBox "Žiadne data": Exit Sub

Separator = Application.PathSeparator

For Each ARE In Oblast.Areas
For Each Cell In ARE.Cells
V = Cell.Value
If Not IsEmpty(V) Then
tmp = Split(V, Separator)
Nazov = tmp(UBound(tmp))
Pos = InStrRev(Nazov, ".")
If Len(Dir(Left$(V, Len(V) - IIf(Pos = 0, 0, Len(Nazov) - Pos - 1)) & "*")) = 0 Then AddColor rngRed, Cell Else AddColor rngGreen, Cell
End If
Next Cell
Next ARE

If Not rngRed Is Nothing Then rngRed.Font.Color = vbRed
If Not rngGreen Is Nothing Then rngGreen.Font.Color = vbGreen
End Subcitovat

Strana:  1 2   další »

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

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.

On-line nástroje