Sayfaları formülleriyle birlikte kopyalamak

[YASINT]

MERHABALAR AÞAÐIDAKİ DOSYAMDA;
YAPMAK İSTEDİÐİM 2000 1 DEKİ VERİLERİ SAYFA1 E FORMÜL YARDIMIYLA ÇEKİYORUM
2000 2 DEKİLERİ SAYFA2 YE ....... 2000 366 DAKİLERİDE SAYFA366 YA ÇEKMEK İSTİYORUM KOPYA OLUÞTUR DEDİÐİMDE FORMÜLÜ ELLE
DEÐİÞTİRMEM GEREKİYOR. GERÇEK DOSYAMDAKİ SAYFALAR 2000 366 YA KADAR GİTTİÃİ İÇİNDE BU İÞİME GELMİYOR BUNU NASIL ÇÃ?ZEBİLİRİM. YARDIMLARINIZ İÇİN TEÞEKKÜRLER.

 

[danersin]

366 * 2 = 732 sayfayı bu şekilde formüller ile birbirine bağlarsanız o dosya çok büyük ihtimalle çökecektir.

Onun haricinde istediğiniz şey için çok pratik bir şey gelmedi aklıma.. amaç ne bu şekilde diğer sayfanın birebir kopyasını formül ile taşımanızda anlatırsanız belki makro ile halledebiliriz.. yada formüllü sayfalardan birinin 366 tane kopyasını alıp sonra sayfalarda ctrl-f ile 2001 1 yerine 2002 2 değiştir şeklinde gidilebilir (makroda aynı şeyi yapacak)

 

[YASINT]

makrosunu yazabilirseniz çok memnun olurum. teşekkürler.

 

[Ali]

Arasında başka bir workbooka kopyalayan kodlarda var ama aradaki kodların bazıları sildim sadece yeni bir sayfaya kopyalamasını sağlayacak kodları bıraktım.Denedim çalışıyor
Görünüm-araç çubukları-özelleştir-komutlar-makrolar-özel düğme ile üstteki menüne taşıyarak bir buton oluşturki her sayfa için bir buton oluşturmak zorunda kalmayasın.Oluşan bu butona aşağıdaki kodları ekle fakat kopyalanacak kısımları mouse ile seç ve makroyu çalıştır. Formülleri ile birlikte kopyalayıp yeni bir sayfa oluşturacaktır.

Option Explicit

Sub Düğme1_Tıklat()
If TypeName(Selection) <> "Range" Then
MsgBox "Bu kodlar worksheeti seçtikten sonra çalışır.", vbInformation, "Hiç bir aralık seçilmedi"
Exit Sub
End If
If Selection.Areas.Count > 1 Then
MsgBox "Bu kodlar çoklu seçimleri desteklemez.", vbInformation, "Çoklu bir alan seçildi"
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 = "Yeni bir çalışma kitabına kopyalanıyor..."
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 = "Yeni bir sayfaya koyalanıyor..."
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 = "Satır yüksekliği ayarlanıyor..."
For r = 1 To .Rows.Count
If Not .Rows(r).Hidden Then
Rows(r).RowHeight = .Rows(r).RowHeight
End If
Next r
Application.StatusBar = "Sütun yüksekliği ayarlanıyor..."
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