< návrat zpět

MS Excel


Téma: Prověření existence adresáře rss

Zaslal/a 12.10.2021 11:19

Dobrý den,

napsal jsem si funkci pro ověřování existence složky na disku.
Cesty jsou generované excelem a vše je plně funkčí.

Poprosil bych, zdy by někdo koukl a případně předal nějaké připomínky.

Děkuji.



Function KontrolaExistenceSlozkyZakazky()

Dim cell As Range
Dim rng As Range

'Definování Aktivního řádku
R = ActiveCell.Row

'Proměné
VyrobniCisloRozvadece = Cells(R, 1)
ZakaznikAkce = Cells(R, 2)
AktualniRok = Format(Now, "yyyy")
ZakazkoveCislo = Mid(VyrobniCisloRozvadece, 1, 4)

OdstranMezeruZakaznikAkce = WorksheetFunction.Trim(ZakaznikAkce)
CistyTvarZakaznikAkce = KontrolaZnaku("" & OdstranMezeruZakaznikAkce & "")

Sheets("Config").Visible = True

ZvolenyAdresar = Workbooks(ZakazkovaKniha).Sheets("Config").Range("route_disc")

Sheets("Temp").Visible = True
Application.ScreenUpdating = False
Workbooks(ZakazkovaKniha).Sheets("Temp").Activate
ActiveSheet.Range("F1").Select


Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ZvolenyAdresar)
Set fc = f.SubFolders
For Each f1 In fc
polozka = f1.Name

ActiveCell.Value = polozka
ActiveCell.Offset(1, 0).Select

Next
Range("F:F").Find("System Volume Information").Delete Shift:=xlUp

PosledniPlnyRadek = Cells(Rows.Count, "F").End(xlUp).Row + 1 ' Ve sloupci F



Set rng = Workbooks(ZakazkovaKniha).Sheets("Temp").Range("F1:F" & PosledniPlnyRadek & "")

Workbooks(ZakazkovaKniha).Sheets("Kniha zakázek").Activate

For Each cell In rng

UmisteniSlozkyZakazkyArr = ZvolenyAdresar & cell.Value & "\" & ZakazkoveCislo & "-" & CistyTvarZakaznikAkce & ""

If Len(Dir(UmisteniSlozkyZakazkyArr, vbDirectory)) = 0 Then
'Nenalezena
Else
KontrolaExistenceSlozkyZakazky = UmisteniSlozkyZakazkyArr
'MsgBox (KontrolaExistenceSlozkyZakazky)

Exit For

End If

If cell.Value = "" Then
MsgBox ("Složka nenalezena")
End If

Next cell


Sheets("Config").Visible = False
Sheets("Temp").Visible = False
Workbooks(ZakazkovaKniha).Sheets("Kniha zakázek").Activate
Application.ScreenUpdating = True

End Function

Zaslat odpověď >

#051339
elninoslov
1. Priložte aj nejaký súbor bez citlivých dát (no nie bez dát!), nech si vieme urobiť predstavu, kde čo je, a čo sa asi tak má robiť.
2. Čo sa má robiť ??? Lepší popis.

Samotné overenie existencie zložky sa dá urobiť aj jednoducho cez Len(Dir(...))=0, ale tu čarujete niečo s bunkami, a bez prílohy sa mi nechce hádať.

EDIT:
Workbooks(ZakazkovaKniha) bude vždy otvorený?
.Select nepoužívajte, ak to nie je nevyhnutné. Použite súradnicové adresovanie bunky cez Cells(y,x)
Nepoužívajte iba Next, ale radšej Next f1. Nepomýlite si tak cykly.
Čo ak Find("System Volume Information") nenájde nič - chyba. Treba ošetriť cez On Error
Raz používate Cells() a hneď na to Workbooks(ZakazkovaKniha)... Je dobré makru určiť, ktorý zošit/list sa spracováva. Nie iba samotné Range/Cells ale aj zošit/list
Chýba funkcia KontrolaZnaku.
...
Bez prílohy + popisu + vzorových dát ani ranu...citovat
#051341
avatar
Je to trochu oholené, funkcí už je hodně a bylo by to nepřehledné.

Podstatné zůstalo.
Příloha: zip51341_kniha.zip (288kB, staženo 6x)
citovat
#051342
avatar
V kartě > Elektrotrend > Nastavení lze upravit adresářovou strukturu a následně simulovat chování.citovat
#051344
avatar
Zdar,
je mi záhadou jak jsi vytvořil tu kartu Elektrotrend, která se zjeví na Ribbonu po otevření souboru 7
Ty tlačítka na kartě jsou sice mrtvé, neboť chybí kód, ale ani v ThisWorkbook není žádný kód pro vytvoření této karty, ani v modulech ani v modulech listů ani ve formulářích.
Co je to za trik?

Předem dík, M.citovat
#051345
Stalker
@Milan-158

https://wall.cz/excel-navod/prizpusobeni-pasu-karet-ribbon-vlastni-pas-karetcitovat

Uživatelské menu

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

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura IV

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

Aktivní diskuse

email z excelu do outlooku

Anonym • 8.12. 17:47

Cells(1, 1).Value = Application.Evaluate COUNTIF

PavDD • 8.12. 13:03

email z excelu do outlooku

PavDD • 8.12. 12:29

email z excelu do outlooku

PavDD • 8.12. 12:26

Stavy měřidel a protokol

Scraper • 8.12. 12:16

Stavy měřidel a protokol

elninoslov • 7.12. 16:15

Stavy měřidel a protokol

Stana-V • 7.12. 11:53