< návrat zpět

MS Excel


Téma: Kontrola existencie suboru v hociakom formate rss

Zaslal/a 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ší »
#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
#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
#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 Sub
citovat
#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
#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
#044177
avatar
Myslite ze by to urychlilo keby nehladalo akukolvek priponu ale zadafenovali sa len 3-4 mozne pripony?citovat
#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
#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
#044182
avatar
Takze odskusane, spomaluje to server. V PC to naslo rychlo.citovat
#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 Sub
citovat

Strana:  1 2   další »

Uživatelské menu

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

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

nahodne cisla

mepexg • 18.9. 12:09

nahodne cisla

pavol14pavol • 17.9. 21:46

Nájsť správne číslo a dosadiť novú hodnotu

Alindros • 17.9. 13:21

Nájsť správne číslo a dosadiť novú hodnotu

Alindros • 17.9. 13:15

Nájsť správne číslo a dosadiť novú hodnotu

Alindros • 17.9. 13:13

Nájsť správne číslo a dosadiť novú hodnotu

Alindros • 17.9. 11:00

nová registrace

kabaka • 17.9. 10:50