For i = 3 To lstrow
if not rows(i).hidden then
xdir = ...
if not rows(i).hidden then
xdir = ...
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Tipy a triky pro Excel a makra VBA
< návrat zpět
Téma: Vytváření složek dle označených buněk
OK, takto tunkční.
Nicméně po testu neosvědčilo se takto.
Lze nějak tedy ošetřit , aby pracovalo pouze s myší označenými buňkami .... tedy např. 5 ( nově přidaných do databáze) ze všech 150 co ve sloupci jsou?
Díky za pomoc
MS Excel
Téma: Vytváření složek dle označených buněk 
Zaslal/a Zemi77 4.5.2022 12:56
Ahoj,
Našel jsem zde a trošku modifkoval pro sebe následující makro. Zjednodušeně mi vytváří složky, které obsahují další dvě stabilní a neměné složky dle seznamu staveb. Ovšem rád bych toto ještě upravil tak, aby makro vytvořilo složky pouze z aktivních buněk. Např. při použití filtru,
Kód:
Sub VyvorSlozku_SUNSET_AMICOM()
Dim xdir As String
Dim lstrow As Long
Dim i As Long
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
For i = 3 To lstrow
xdir = "C:\Users\Petr.Zemek\Desktop\Práce\VB\AMICOM\" & Range("B" & i).Value
On Error Resume Next
MkDir xdir
If Err.Number = 0 Then 'když existuje, jde dál
MkDir xdir & "\Podklady"
MkDir xdir & "\Výstavba"
End If
On Error GoTo 0
Next
End Sub
Díky za rady
JoKe napsal/a:
For i = 3 To lstrow
if not rows(i).hidden then
xdir = ...
OK, takto tunkční.
Nicméně po testu neosvědčilo se takto.
Lze nějak tedy ošetřit , aby pracovalo pouze s myší označenými buňkami .... tedy např. 5 ( nově přidaných do databáze) ze všech 150 co ve sloupci jsou?
Díky za pomoc
S tím aktuálním výběrem (Selection) zkusit průsečík dvou oblastí (Intersect), zde pokus najít viditelné buňky (resp. neskryté řádky filtrem či manuálně) ve sloupci B počínaje třetím řádkem ...
Dim rng(1 To 3) As Range, c As Range
Set rng(1) = Selection
Set rng(2) = rng(1).Parent.Range("B3:B" & rng(1).Parent.Cells(1).CurrentRegion.Rows.Count).SpecialCells(xlCellTypeVisible)
Set rng(3) = Application.Intersect(rng(2), rng(1))
For Each c In rng(3).Cells
Debug.Print c.Value
Next
Snad to bude fungovat s libovolným výběrem ...
Dim rng(1 To 3) As Range, c As Range
Set rng(1) = Selection
Set rng(2) = rng(1).Parent.Range("B3:B" & rng(1).Parent.Cells(1).CurrentRegion.Rows.Count).SpecialCells(xlCellTypeVisible)
Set rng(3) = Application.Intersect(rng(2), rng(1))
For Each c In rng(3).Cells
Debug.Print c.Value
Next
Snad to bude fungovat s libovolným výběrem ...
Pokus vypsat z tabulky (na aktivním listu s levým horním rohem v buňce A1 a záhlavím v prvním řádku) názvy složek ze sloupce B, kde není složka ještě založena ...
Upřesnění konktétního listu, stávající oblasti tabulky a cestu k hlavnímu adresáři upravit dle vlastního uvážení.
Dim folder_names
Const folder_path As String = "C:\Users\User\Desktop\AMICOM"
Dim current_range As Range
Dim ws As Worksheet: Set ws = ActiveSheet
With ws.Cells(1).CurrentRegion
If .Rows.Count > 0 And .Columns.Count > 0 Then
folder_names = Application.Transpose(.Columns("B").Offset(1).Resize(.Rows.Count - 1).Value)
End If
End With
Dim r As Long, new_items As New VBA.Collection
If Not IsEmpty(folder_names) Then
For r = LBound(folder_names) To UBound(folder_names)
'Debug.Print folder_names(r)
If Not Len(Dir(folder_path & Application.PathSeparator & folder_names(r), vbDirectory)) > 0 Then
new_items.Add folder_names(r)
End If
Next
End If
For r = 1 To new_items.Count
Debug.Print new_items(r)
'MkDir folder_path & Application.PathSeparator & cell_range.Value
Next
Upřesnění konktétního listu, stávající oblasti tabulky a cestu k hlavnímu adresáři upravit dle vlastního uvážení.
Dim folder_names
Const folder_path As String = "C:\Users\User\Desktop\AMICOM"
Dim current_range As Range
Dim ws As Worksheet: Set ws = ActiveSheet
With ws.Cells(1).CurrentRegion
If .Rows.Count > 0 And .Columns.Count > 0 Then
folder_names = Application.Transpose(.Columns("B").Offset(1).Resize(.Rows.Count - 1).Value)
End If
End With
Dim r As Long, new_items As New VBA.Collection
If Not IsEmpty(folder_names) Then
For r = LBound(folder_names) To UBound(folder_names)
'Debug.Print folder_names(r)
If Not Len(Dir(folder_path & Application.PathSeparator & folder_names(r), vbDirectory)) > 0 Then
new_items.Add folder_names(r)
End If
Next
End If
For r = 1 To new_items.Count
Debug.Print new_items(r)
'MkDir folder_path & Application.PathSeparator & cell_range.Value
Next
K plné spokojenosti ošetřeno následujícím kodem :
Sub VyvorSlozku_SUNSET_LIKEMA()
Dim xdir As String
Dim lstrow As Long
Dim i As Long
Dim cell As Range
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
For Each cell In Selection
xdir = "E:\TEST\AMI\LIKEMA\" & cell.Value
On Error Resume Next
MkDir xdir
If Err.Number = 0 Then 'když existuje, jde dál
MkDir xdir & "\Podklady"
MkDir xdir & "\Výstavba"
End If
On Error GoTo 0
Next
End Sub
děkuji za pomoc
Sub VyvorSlozku_SUNSET_LIKEMA()
Dim xdir As String
Dim lstrow As Long
Dim i As Long
Dim cell As Range
lstrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
For Each cell In Selection
xdir = "E:\TEST\AMI\LIKEMA\" & cell.Value
On Error Resume Next
MkDir xdir
If Err.Number = 0 Then 'když existuje, jde dál
MkDir xdir & "\Podklady"
MkDir xdir & "\Výstavba"
End If
On Error GoTo 0
Next
End Sub
děkuji za pomoc
Lepší způsob jak to udělat během par sec. je použít cmd (.bat soubor)
Pokud máte seznam jmen v excelu, doplňte pomocí vzorečku slovo MKdir před jmeno (název složky) a pokud obsahuje mezeru dejte název do uvozovek. Poté stačí jen zkopírovat do oznámkového bloku (NotePad), dát uložit jako a dopsat příponu .bat . Jakmile toto máte, supsťte .bat soubor ve složce kde chce aby se vytvořili a máte to.
Pokud chcete aby se cmd nezavřelo napište na konec puase jako je níže
Zde je ten 3 slovný kód
:
start
________
MKdir "Pixie Pin"
pause
________
konec
toto vytvoří složku s názvem Pixie Pin ve složce kde byl příkaz spuštěn
Pokud máte seznam jmen v excelu, doplňte pomocí vzorečku slovo MKdir před jmeno (název složky) a pokud obsahuje mezeru dejte název do uvozovek. Poté stačí jen zkopírovat do oznámkového bloku (NotePad), dát uložit jako a dopsat příponu .bat . Jakmile toto máte, supsťte .bat soubor ve složce kde chce aby se vytvořili a máte to.
Pokud chcete aby se cmd nezavřelo napište na konec puase jako je níže
Zde je ten 3 slovný kód
:start
________
MKdir "Pixie Pin"
pause
________
konec
toto vytvoří složku s názvem Pixie Pin ve složce kde byl příkaz spuštěn
No hej, ale reálny rozdiel/prínos bude aký? Aj tak si makrom musí urobiť zoznam z vybranej oblasti, a keď už makro beží, rovno sa názov môže poslať ako parameter do MkDir. Namiesto toho aby som si niekde uložil zoznam a potom ho nakopíroval do BAT (alebo makrom vytvoril BAT súbor). Aký bude časový rozdiel vykonávania operácie (spomínaných 5 foldrov)? 0,01 sek v prospech BAT?
Pokud potřebuji opakovaně zakládat adresáře se zadanou strukturou, používám samozřejmě bat. Otevřu adresář a v něm spustím skript:
@echo off
chcp 1250 > nul:
if .%1.==.. (echo Není zadán adresář [nebo jiná zpráva] && goto konec)
mkdir .\%1 2> nul:
if errorlevel 1 (echo dir existuje && goto konec)
:: Do v závorce je seznam adresářů
for %%i in (Podklady AAA\Výstavba "X x x") do mkdir .\%1\%%i
echo hotovo
:konec
rem exit
Ve srovnání se skriptem v excelu je to o hodně rychlejší, a případná modifikace stromu adresářů je také velmi snadná.
@echo off
chcp 1250 > nul:
if .%1.==.. (echo Není zadán adresář [nebo jiná zpráva] && goto konec)
mkdir .\%1 2> nul:
if errorlevel 1 (echo dir existuje && goto konec)
:: Do v závorce je seznam adresářů
for %%i in (Podklady AAA\Výstavba "X x x") do mkdir .\%1\%%i
echo hotovo
:konec
rem exit
Ve srovnání se skriptem v excelu je to o hodně rychlejší, a případná modifikace stromu adresářů je také velmi snadná.
BAT bude rýchlejší, jasne to v poslednej vete píšem, ale tu sa jedná o mizivé počty, spomína 5 ks. Čo znamená, že najzdĺhavejšia časť, ktorá musí prebehnúť v oboch prípadoch, je vytvorenie zoznamu prechádzaním buniek (napr. Intersect zo Selection a/alebo SpecialCells). Pochybujem, že stačíte 2x mrknúť pri takom počte foldrov
Ale BAT bude vždy rýchlejší, to áno.
Ale BAT bude vždy rýchlejší, to áno.
Uživatelské menu
Nejste přihlášen(a)
\n
\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