EXCEL SAYFASINI AYRI BİR DOSYA YAPMAL

[YASINT]

EXCEL SAYFASINI AYRI BÝR DOSYA YAPMAL

MERHABA ARKADAÞLAR BİR EXCEL DOSYASINDAKİ SAYFALARI İÇERİÃİ İLE BİRLİKTE AYRI BİR EXCEL DOSYASI YAPABİLİRMİYİZ. BU MÜMKÜN MÜDÜR MÜMKÜN İSE NASIL YAPABİLİRİM. TEÞEKKÜRLER.

 

[muygun]

slm.
kopya oluşturacağın dosya açık iken;
alt kısımda sayfa isimleri (sayfa1) üzerine gel
sağ tuş ile "taşı veya kopyala"yı seç
çıkan pencerede üst tarafta "yeni kitap" ı seç
kopya oluştur u işaretle
tamam

 

[YASINT]

OK. ÇOK GÜZEL VERDİÐİN BİLGİ İÇİN TEÞEKKÜRLER FAKAT BENİM DOSYAMDA 100 DEN FAZLA SAYFA OLDUÐU İÇİN DOSYA ÞİÞİYOR BUNUN İÇİNDE HEPSİNİ AYRI BİR SAYFADA TUTMAK İSTİYORUM BUNU ENİN DEDİÐİN ÞEKİLDE YAPARSAM ÇOK VAKİT ALACAK. BU İÞLEMİ OTOMATİK OLARAK YAPTIRAMAZMIYIM.

 

[Ali]

Dosya-Farklı kaydeti seç bir yeni bir isim ver aynısından bir tane daha olsun.En kolayı bu.

 

[Ali]

Çalışma sayfasındaki her bir sayfayımı ayırmak istiyorsun

 

[Ali]

Bir buton oluştur ve buna aşağıdaki kodları ekle. Her sayfayı yeni çalışma kitabına aktarır


Option Explicit
Sub Düğme1_Tıklat()


If TypeName(Selection) <> "Range" Then
MsgBox "This action requires you to select a worksheet range.", vbInformation, "No worksheet range selected"
Exit Sub
End If
If Selection.Areas.Count > 1 Then
MsgBox "This action does not support multiple range selections.", vbInformation, "Multiple areas selected"
Exit Sub
End If
CopySelection Selection, True, True
End Sub

Sub CopyWorksheetRangeToNewWS()
Range("MyInputRange").Select
If TypeName(Selection) <> "Range" Then
MsgBox "This action requires you to select a worksheet range.", vbInformation, "No worksheet range selected"
Exit Sub
End If
If Selection.Areas.Count > 1 Then
MsgBox "This action does not support multiple range selections.", vbInformation, "Multiple areas selected"
Exit Sub
End If
CopySelection Selection, False, False
End Sub

Private Sub CopySelection(InputRange As Range, CopyToNewWB As Boolean, CopyValuesOnly As Boolean)
Dim SourceWB As Workbook, TargetWB As Workbook, SourceRange As Range
Dim SourceWS As Worksheet, TargetWS As Worksheet
Dim r As Long, c As Long, TempName As String
On Error Resume Next
Set SourceRange = InputRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If SourceRange Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set SourceWS = InputRange.Parent
Set SourceWB = InputRange.Parent.Parent
If CopyToNewWB Then
Application.StatusBar = "Copying to new workbook..."
Set TargetWB = Workbooks.Add
Application.DisplayAlerts = False
While TargetWB.Worksheets.Count > 1
TargetWB.Worksheets(2).Delete
Wend
Application.DisplayAlerts = True
If TargetWB.Worksheets.Count = 0 Then
TargetWB.Worksheets.Add
End If
SourceWB.Activate
SourceRange.Copy
TargetWB.Activate
If CopyValuesOnly Then
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial xlPasteFormats
Else
Range("A1").PasteSpecial xlPasteAll
End If
Application.CutCopyMode = False
ActiveSheet.Name = SourceWS.Name
Else
Application.StatusBar = "Copying to new worksheet..."
Set TargetWS = SourceWB.Worksheets.Add(After:=InputRange.Parent)
SourceWS.Activate
SourceRange.Copy
TargetWS.Activate
If CopyValuesOnly Then
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial xlPasteFormats
Else
Range("A1").PasteSpecial xlPasteAll
End If
Application.CutCopyMode = False
r = 0
TempName = ActiveSheet.Name
Do
r = r + 1
On Error Resume Next
ActiveSheet.Name = SourceWS.Name & r
Loop Until TempName <> ActiveSheet.Name
End If
With InputRange
Application.StatusBar = "Editing rowheights..."
For r = 1 To .Rows.Count
If Not .Rows(r).Hidden Then
Rows(r).RowHeight = .Rows(r).RowHeight
End If
Next r
Application.StatusBar = "Editing columnwidths..."
For c = 1 To .Columns.Count
If Not .Columns(c).Hidden Then
Columns(c).ColumnWidth = .Columns(c).ColumnWidth
End If
Next c
End With
Range("A1").Select
Set SourceRange = Nothing
Set SourceWS = Nothing
Set SourceWB = Nothing
Set TargetWS = Nothing
Set TargetWB = Nothing
Application.StatusBar = False
End Sub

 

[YASINT]

ÇOK TEÞEKKÜRLER FRUCTOSE