IZBORNIK HOME FORUM ACCESS 2003 EXCEL 2003 WORD 2003  .
   
   
HOME
FORUM Win Tips&Tricks
   
KAKO INSTALIRATI
WINDOWS XP ?
Kako instalirati Win XP sa USB STICKA
Kako instalirati WINDOWS 7 ?
Naučite za 15 minuta raditi u Windows XP
Naučite Internet Explorer i Outlook Express
za 15 minuta
Kako kreirati BOOT CD za instalaciju Win95
   
MS OFFICE 2003
MS OFFICE 2007
   
   
HOME NETWORK
tutorijal za mreže
Network Windows 7 - XP
   
ZANIMLJIVI LINKOVI
BROJEVNI SUSTAVI
(DEC, OKT, BIN, HEX )
CMD - Command Prompt
CISCO - CCNA tutoriali
VLSM and SUBNETTING
   
Tutorijali za phpBB forum
JAVASCRIPT
VISUAL BASIC 6.0
AUTOCAD 2007
 
.
MICROSOFT EXCEL 2007 - kako kopirati Specifične radne listove u novu excel datoteku i snimiti

Kopiranje određenih radnih listova u novu radnu knjigu
(Copy specific Sheets to new Workbook and Save)

Search This Web Site




Kako kopirati određene Sheets u New Workbook (via VBA)

U koliko imate potrebu u radnoj knjizi (Workbook) kopirati pojedine ili određene radne listove (Sheets) u novu radnu knjigu (new Workbook) ili Excelovu datoteku i to sve snimiti tada možete iskoristiti jedan od nevedenih Macro-a

Iako nije problem jedan ili više Sheets selektirati (preko CTRL) pa kliknuti desnom tipkom miša na jedan od njih pa na "Move or Copy" => New Book uz uključivanje opcije "Create a Copy" i nakon toga snimiti dotičnu novu Workbook

No svi težimo automatizaciji pa evo nekih primjera.


Kopiranje trenutnog Sheeta u New Workbook na C:\Temp

Ovo je Macro za kopiranje/snimanje trenutnog Sheeta (ActiveSheet) na kojem se nalazimo u New Workbook. Izmjenite path stazu prema svojim potrebama, ova trenutno snima na C:\Temp

Sub CopySheetToNewWorkbook()
Application.ScreenUpdating = False
ActiveSheet.Select
ActiveSheet.Copy
With ThisWorkbook
ActiveSheet.SaveAs Filename:=("C:\Temp\Backup of " & .Name)
Application.ScreenUpdating = True
ActiveWorkbook.Close
End With
End Sub


Kopiranje specifičnih Sheets u novu Workbook na određenu lokaciju
(ime nove Workbook postavljamo u ćeliji kao vrijednost)

.  

U slučaju da radite na jednoj te istoj Workbook stalno i imate potrebu snimanja i kopiranja više Sheets u novu Workbook pa snimiti zasebno.
Ovo su Macro-i koji se stavljaju u VBE u dotični Sheet koji želite kopirati u novu Workbook
U ćeliji svakog Sheeta A1 upisuje redni broj po kojem želite imenovati novu Workbook. Naravno možete izabrati i neku drugu ćeliju. Umjesto C:\Temp postavite Path stazu po želji


Ovu makronaredbu kopirati u VBE - u Sheet1 => Code Window.
Ili kliknuti DTM na dotični Sheet => View Code => Paste makronaredbu u Code Window

Sub CopySheet1ToNewWorkbook()
Dim x As Variant, c As Range
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Sheet1")
x = .Range("A1").Value
.Copy
End With
For Each c In ActiveWorkbook.Sheets(1).UsedRange
c.Value = c.Value
Next c
ActiveWorkbook.SaveAs Filename:="C:\Temp\" & x & ".xls"
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub


Ovu makronaredbu kopirati u VBE - u Sheet1 => Code Window.
Ili kliknuti DTM na dotični Sheet => View Code => Paste makronaredbu u Code Window

Sub CopySheet3ToNewWorkbook()
Dim x As Variant, c As Range
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Sheet3")
x = .Range("A1").Value
.Copy
End With
For Each c In ActiveWorkbook.Sheets(1).UsedRange
c.Value = c.Value
Next c
ActiveWorkbook.SaveAs Filename:="C:\Temp\" & x & ".xls"
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

Pokrećete makronaredbu sa ALT+F8 po želji izbora Sheeta za snimanje


Kako kopirati sve Sheets i kreirati nove Workbook nazivom radnih listova na određenu lokaciju

Ovo je Macro koji će ti iz vaše trenutne Workbook kreirati nove files za svaki Sheet u Workbook i imenovati file nazivom Sheeta.
Ovaj Macro kopirati u Module dotične Workbook. Path stazu promijenite po želji

Sub createFilesFromSheets()
' Declare variables
Dim ws As Worksheet, mySheet, myPath
myPath = "C:\TEMP"
' Loop through the worksheets in the workbook & create new file for each sheet
For Each ws In ActiveWorkbook.Worksheets
' Get the worksheet name...
mySheet = ws.Name
' Make a copy of the worksheet...
ws.Copy Before:=Worksheets(1)
' Move worksheet to a new file...
Worksheets(1).Move
' Name new worksheet as its' parent...
ActiveSheet.Name = mySheet
' Save the new file...
' Set the file directory to search for previous version...

ChDir myPath
' Delete previous version of the file (if it exists)...
On Error Resume Next
Kill myPath & "\" & mySheet & ".xls"
' Save as Excel file w/Sheet name
ActiveWorkbook.SaveAs Filename:=myPath & "\" & mySheet & ".xls", FileFormat:= _
xlWorkbookNormal, CreateBackup:=False
' Close the new file...
ActiveWindow.Close SaveChanges:=False
Next ws
End Sub

Adsense sponzor



Macro pokrećete  sa ALT+F8


Kopiranje određenih Sheets u novu Workbook  sa specifičnim nazivom na određenu lokaciju

Ovaj Macro će kopirati Sheets (Sheet1 i Sheet2) koje postavite u makronaredbi na C:\temp pod nazivom Bekap.xls
Vodite računa da koristite CodeName za Sheets kao što je u makronaredbi. Postaviti ga u Module dotične Workbook

Sub CopySpecificSheetToNewWorkbook()

Dim OutlookApp As Object
Dim MItem As Object
Dim Wb As Workbook
Dim NewWb As Workbook

Set Wb = ActiveWorkbook
Sheets(Array(Sheet1.Name, Sheet2.Name)).Copy
Set NewWb = ActiveWorkbook
NewWb.SaveAs "C:\Temp\Bekap.xls"
NewWb.Close

End Sub

 

Adsense sponzor



Macro pokrećete  sa ALT+F8 ili preko buttona


Kopiranje određenih Sheets u novu Workbook a snimanje se vrši u istom folderu ili na određenu lokaciju
(prilikom pokretanja makronaredbe samo postavljate naziv nove workbook)

Ovaj Macro kopira određene Sheet u novu Workbook u istom folderu. Imena Sheets definiraju se u Makronaredbi
Prilikom pokretanja makronaredbe pojavljuje se dijalog prozor gdje je potrebno kliknuti OK pa potom na novom dijalog prozoru postaviti naziv za novu Workbook

Option Explicit

Sub TwoSheetsAndYourOut()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet

If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub

With Application
.ScreenUpdating = False

' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas

On Error Goto ErrCatcher
Sheets(Array("Skladiste", "Izvjesce")).Copy
On Error Goto 0

' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets

For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select

' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm

' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
'ako želimo snimiti na određenu lokaciju tada koristimo ove dvije linije koda ispod a dvije iznad komentiramo
'ActiveWorkbook.SaveAs Filename:="C:\Temp" & "\" & NewName & ".xls"
'ActiveWorkbook.Close 'SaveChanges:=False

.ScreenUpdating = True
End With
Exit Sub

ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub

Adsense sponzor




Kako kopirati sve radne listove u novu Workbook na određenu lokaciju
(Copy All Sheets to New Workbook on specific location)

Ovaj Macro ispod kopira sve Sheets u novu Workbook na C:\Temp i snima pod imenom koje smo upisali u ćeliju A1 na prvom Sheetu (Sheet1), doslovno pravi backup dotične Workbook. Autor neptuncokg

Sub CopyAllSheets()

Application.ScreenUpdating = False

Dim WB As ThisWorkbook, NEWname As String, fname As String, i As Byte, brSH As Byte

Set WB = ThisWorkbook
'trenutno otvorena Workbook
fname = WB.Sheets("AAA").Range("A1").Value
'naziv nove Workbook koji je upisan u A1 na Sheet1
brSH = WB.Sheets.Count

Application.DisplayAlerts = False
'izvršava overwrite ako već postoji workbook s dotičnim nazivom

Workbooks.Add
'kreiranje nove workbook
ActiveWorkbook.SaveAs Filename:="C:\Temp\" & fname, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
NEWname = ActiveWorkbook.Name 
'naziv novoformirane workbook - zbog narednih kodova

If brSH = 2 Then ActiveWorkbook.Sheets(3).Delete
'ako je u Excelu definirano da nova workbook ima samo 2 Sheeta
If brSH = 1 Then ActiveWorkbook.Sheets(Array(2, 3)).Delete '
ako je u Excelu definirano da nova workbook ima samo 1
If brSH > 3 Then '
ako je u Excelu definirano da nova workbook ima samo više od 3 Sheeta
For i = 1 To brSH - 3
ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count), Count:=1
'novi Sheet smješta na kraju

Next
End If

For i = 1 To brSH

WB.Sheets(i).Cells.Copy
'Kopiranje svih ćelija sa postojećih Sheets trenutne Workbook na =>nova naredba
Workbooks(NEWname).Sheets(i).Activate 
'=> nastavak prethodne naredbe => sve Sheets nove Workbook
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

On Error Resume Next
'ignorira potencijalnu grešku zbog naziva Sheets
Workbooks(NEWname).Sheets(i).Name = WB.Sheets(i).Name
' kopira imena svih Sheets
On Error GoTo 0

Sheets(i).Range("A1").Select
'u svim Sheets selektira A1
Sheets(1).Activate
'Aktivira u prvi plan Sheet1

Next

Workbooks(NEWname).Close True
'zatvara novu Workbook i snima je na lokaciju

Application.DisplayAlerts = True

End Sub

Na jednom mjestu popis svih tema vezanih za kopiranje (copy) u Excelu: Tutorijali vezani za radnje kopiranja u Excelu




©- 2006 - 2018 - IvanC  - Sva prava pridržana.  ic.ims.hr