Makro za kreiranje map v explorerju iz tabele
Makro za kreiranje map v explorerju iz tabele
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č.
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č.
Re: Makro za kreiranje map na serverju iz tabele
Pozdravljeni,
Del makra, kjer formatirate števila mora izgledati takole:
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
Matjaž Prtenjak
Administrator
Re: Makro za kreiranje map v explorerju iz tabele
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.
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.
Re: Makro za kreiranje map v explorerju iz tabele
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![Sad :(](./images/smilies/icon_sad.gif)
Tam bo seveda potrebno napisati
![Sad :(](./images/smilies/icon_sad.gif)
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
![Sad :(](./images/smilies/icon_sad.gif)
Tam bo seveda potrebno napisati
Koda: Izberi vse
nacrt = Cells(i, 3).Value
lp,
Matjaž Prtenjak
Administrator
Matjaž Prtenjak
Administrator
Re: Makro za kreiranje map v explorerju iz tabele
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?
Re: Makro za kreiranje map v explorerju iz tabele
Namesto:
Naredite novo mapo samo če ste našli /, torej:
Koda: Izberi vse
MkDir (nova_mapa)
Koda: Izberi vse
If delitev > 0 Then
MkDir (nova_mapa)
End if
lp,
Matjaž Prtenjak
Administrator
Matjaž Prtenjak
Administrator
Re: Makro za kreiranje map v explorerju iz tabele
Zamenjal sem to vrstico, a še vseeno napravi mapice.
Re: Makro za kreiranje map v explorerju iz tabele
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
Matjaž Prtenjak
Administrator
Re: Makro za kreiranje map v explorerju iz tabele
Najlepša hvala za pomoč!