MS Excel

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ěď >

elninoslov(12.10.2021 12:58)#051339

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

Onykl(12.10.2021 13:20)#051341

Je to trochu oholené, funkcí už je hodně a bylo by to nepřehledné.

Podstatné zůstalo.

Příloha: zip

51341_kniha.zip (288kB, staženo 16x)

citovat

Onykl(12.10.2021 13:25)#051342

V kartě > Elektrotrend > Nastavení lze upravit adresářovou strukturu a následně simulovat chování.citovat

Milan-158(14.10.2021 16:20)#051344

Zdar,
je mi záhadou jak jsi vytvořil tu kartu Elektrotrend, která se zjeví na Ribbonu po otevření souboru

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

Stalker(14.10.2021 20:30)#051345

@Milan-158

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

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

Uživatelské menu

Menu

Formulář Faktura

Formulář Faktura IV

Helios iNuvio

On-line nástroje