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.
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
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.
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
Sizlere daha iyi bir deneyim sunabilmek icin sitemizde çerez konumlandırmaktayız, web sitemizi kullanmaya devam ettiğinizde çerezler ile toplanan kişisel verileriniz Veri Politikamız / Bilgilendirmelerimizde belirtilen amaçlar ve yöntemlerle mevzuatına uygun olarak kullanılacaktır.