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
Tam bo seveda potrebno napisati
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
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č!