prekopira v nov delovni zvezek v tabelo ( vsaka datoteka ena vrstica).
Makro zaganjam iz posebnega zvezka.
Imam pa naslednja vprašanja:
- Ko v makru zapiram datoteko (WB.close) dobim sporočilo "Ali želite shraniti spremembe...". Sporočilo se lahko pojavi velikokrat.
Rad bi datoteko zaprl brez shranjevanja. Ali lahko to naredim v makru brez, da dobim sporočilo?
- Ali lahko preberem (ugotovim) v katerem imeniku je trenutno odprta datoteka. Rad bi da se vse izvaja v mapi, od kjer sem zagnal osnovni zvezek.
Prilagam kodo.
Koda: Izberi vse
Sub PripraviPorocilo()
'
' Makro "PripraviPorocilo"
' Prebere vse datoteke "Porocilo????.xlsm" v mapi in prepiše
' podatke iz teh datotek v tabelo v novem poročilu.
'
Dim StVr As Integer ' Številka vrstice
Dim wRow As String ' Pozicija vrivanja vrstice
Dim RangVr As String ' Področje vrstice
Dim Mapa As String ' Mapa v kateri so datoteke
Dim ZbirPor As Workbook ' Nov zvezek "Zbirno porocilo"
Dim ImePor As String ' Ime novega poročila
Mapa = "D:\Test\Joze\Arhiv" ' Določim mpo, v kateri delam
StVr = 5 ' Začetna vrstiva tabele ( minus 1 )
Set ZbirPor = Workbooks.Open("D:\Test\Joze\Arhiv\ZbirnoInit.xlsm") ' Odprem "prazno" zbirno poročilo
ZbirPor.SaveAs ("D:\Test\Joze\Arhiv\ZbirnoPor1.xlsm") ' Shramim z novim imenom
ImePor = ZbirPor.Name ' Ime zbirnega poročila
Dim Datoteka
Datoteka = Dir(Mapa & "\Porocilo*.xlsm") ' Preberem spisek datotek - poročil
Do While Datoteka <> "" ' V zanki obdelam cel spisek
Dim WB
Set WB = Workbooks.Open(Mapa & "\" & Datoteka) ' Preberem naslednjo datoteko
StVr = StVr + 1 ' Povečam vrstico
wRow = StVr & ":" & StVr ' Lokacija vrivanja vrstice
RangVr = "B" & StVr ' Lokacija kopiranja
Windows(ImePor).Activate ' Aktiviram Trenutno poročilo
Rows(wRow).Select ' Določim lokacijo vrivanje
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Windows(WB.Name).Activate
Sheets("Porocilo").Select
Range("B4:AB4").Select
Selection.Copy
Windows(ImePor).Activate
Range(RangVr).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range(RangVr).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
WB.Close
Datoteka = Dir
Loop
End Sub