Makro za kreiranje map v explorerju iz tabele

Pomoč pri izdelavi makrov
Odgovori
sash92
Prispevkov: 7
Pridružen: Po Mar 07, 2022 10:35 am

Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a sash92 »

Pozdravljeni,

Ustvarjam makro, da se iz tabele v excelu ustvarijo mape na računalniku.
Želim, da se zapis iz tabele (2/1 Načrt ceste) zapiše kot poimenovanje mape v "02-01 Načrt ceste".
Trenutno imam razvit tale VBA:

Sub ustvari_mape()
'
' Makro4 Makro
'

'
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Izberi strukturo projekta"
.Filters.Clear
.Filters.Add "Excel", "*.xlsx"
.Filters.Add "Excel", "*.xlsm"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
str_pro = .SelectedItems(1)
End With


Set objWorkbook = Excel.Application.Workbooks.Open(str_pro)

If Not objWorkbook.Sheets(1).Cells(7, 2).Value = "NAČRT" Then
MsgBox ("Ni pravilna struktura projekta")
Exit Sub
End If

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Izberi mapo"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
mapa = .SelectedItems(1)
End With

a = 7
b = Cells(1000, 4).End(xlUp).Row
On Error Resume Next
For i = a To b
If Not Cells(i, 4) = "" Then
vr = i
st_nac = Cells(vr, 2).Value
delitev = InStr(1, st_nac, "/")
If delitev > 0 Then
st_nac = Replace(st_nac, "/", "-")
levi_del = Left(st_nac, delitev)
desni_del = Right(st_nac, Len(st_nac) - delitev)
If Len(desni_del) = 1 Then
desni_del = "0" & desni_del
st_nac = levi_del & desni_del
End If
End If

nacrt = Cells(vr, 3).Value
nacrt = Replace(nacrt, Chr(34), "")
nova_mapa = mapa & "\" & st_nac & " " & nacrt
MkDir (nova_mapa)
End If
Next
Workbooks(str_pro).Close SaveChanges:=False
ThisWorkbook.Close SaveChanges:=False

End Sub


Zatakne se mi, ko bi moral dodati 0 pri levem delu oštevilčenja iz polja (st_nac), kjer gre za 1-mestno številko – recimo "02/02 Načrt ceste", pri 2-mestnem pa ne rabi: "11/02 načrt ceste".
V mapah morajo biti številke obvezno 2-mestne ("02/02" ali pa "11/11").

Tabela iz katere črpa podatke: https://projekti.lineal.si/share/s/GAjn ... u0yP47KftQ

Prosim za pomoč.
admin
Site Admin
Prispevkov: 3704
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Makro za kreiranje map na serverju iz tabele

Odgovor Napisal/-a admin »

Pozdravljeni,

Del makra, kjer formatirate števila mora izgledati takole:

Koda: Izberi vse

    If Not Cells(i, 4) = "" Then
      st_nac = Cells(i, 2).Value
      delitev = InStr(1, st_nac, "/")
      If delitev > 0 Then
        levi_del = Int(Left(st_nac, delitev - 1))
        desni_del = Int(Right(st_nac, Len(st_nac) - delitev))
        st_nac = Format(levi_del, "00") & "-" & Format(desni_del, "00")
      End If
    End If
lp,
Matjaž Prtenjak
Administrator
sash92
Prispevkov: 7
Pridružen: Po Mar 07, 2022 10:35 am

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a sash92 »

Hvala za odgovor, oštevilčenje sedaj deluje, ko vstavim vaš del.
Edino kar sedaj noče, je to, da ne vnese teksta v drugem delu poimenovanja.

Sedaj naredi samo: "00-02", namesto "00-02 Načrt ceste".

Makro:
Sub ustvari_mape()
'
' Makro4 Makro
'

'
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Izberi strukturo projekta"
.Filters.Clear
.Filters.Add "Excel", "*.xlsx"
.Filters.Add "Excel", "*.xlsm"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
str_pro = .SelectedItems(1)
End With


Set objWorkbook = Excel.Application.Workbooks.Open(str_pro)

If Not objWorkbook.Sheets(2).Cells(7, 2).Value = "NAČRT" Then
MsgBox ("Ni pravilna struktura projekta")
Exit Sub
End If

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Izberi mapo"
.Show
If .SelectedItems.Count = 0 Then
Exit Sub
End If
mapa = .SelectedItems(1)
End With

a = 7
b = Cells(1000, 4).End(xlUp).Row
On Error Resume Next
For i = a To b
If Not Cells(i, 4) = "" Then
st_nac = Cells(i, 2).Value
delitev = InStr(1, st_nac, "/")
If delitev > 0 Then
levi_del = Int(Left(st_nac, delitev - 1))
desni_del = Int(Right(st_nac, Len(st_nac) - delitev))
st_nac = Format(levi_del, "00") & "-" & Format(desni_del, "00")
End If
End If

nacrt = Cells(vr, 3).Value
nacrt = Replace(nacrt, Chr(34), "")
nova_mapa = mapa & "\" & st_nac & " " & nacrt
MkDir (nova_mapa)

Next
Workbooks(str_pro).Close SaveChanges:=False
ThisWorkbook.Close SaveChanges:=False

End Sub


Prosim še za popravek tega.
admin
Site Admin
Prispevkov: 3704
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a admin »

Ah, dajte no :(

Pišete, da ste ta makro sami napisali. Ja spodaj ob dnu makra prirejate spremenljivki nacrt vrednost iz celice v vrstici vr... ta vrednost pa seveda ni določena, saj sem vam jaz kodo napisal brez uporabe vr spremenljivke :(

Tam bo seveda potrebno napisati

Koda: Izberi vse

nacrt = Cells(i, 3).Value
lp,
Matjaž Prtenjak
Administrator
sash92
Prispevkov: 7
Pridružen: Po Mar 07, 2022 10:35 am

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a sash92 »

Hvala. Kaj pa, da bi dodal še to, da kjer je spredaj 1-mestno število ("2 Načrti s področja gradbeništva"), da teh vrstic ne spremeni v mape?
admin
Site Admin
Prispevkov: 3704
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a admin »

Namesto:

Koda: Izberi vse

MkDir (nova_mapa)
Naredite novo mapo samo če ste našli /, torej:

Koda: Izberi vse

If delitev > 0 Then
  MkDir (nova_mapa)
End if
lp,
Matjaž Prtenjak
Administrator
sash92
Prispevkov: 7
Pridružen: Po Mar 07, 2022 10:35 am

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a sash92 »

Zamenjal sem to vrstico, a še vseeno napravi mapice.
admin
Site Admin
Prispevkov: 3704
Pridružen: Sr Jul 20, 2005 10:06 pm

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a admin »

Ker imate napačno postavljen IF stavek, saj mapo ustvarjate četudi v koloni D nimate napisano nič. Glede na to kar želite je torej pravilna koda sledeča:

Koda: Izberi vse

For i = a To b
  If Not Cells(i, 4) = "" Then
    st_nac = Cells(i, 2).Value
    delitev = InStr(1, st_nac, "/")
    If delitev > 0 Then
      levi_del = Int(Left(st_nac, delitev - 1))
      desni_del = Int(Right(st_nac, Len(st_nac) - delitev))
      st_nac = Format(levi_del, "00") & "-" & Format(desni_del, "00")
    End If
  
    nacrt = Cells(i, 3).Value
    nacrt = Replace(nacrt, Chr(34), "")
    nova_mapa = mapa & "\" & st_nac & " " & nacrt
    
    If (delitev > 0) Then
      MkDir (nova_mapa)
    End If
  End If
Next
lp,
Matjaž Prtenjak
Administrator
sash92
Prispevkov: 7
Pridružen: Po Mar 07, 2022 10:35 am

Re: Makro za kreiranje map v explorerju iz tabele

Odgovor Napisal/-a sash92 »

Najlepša hvala za pomoč!
Odgovori