FORMÜLSÜZ SAYFAYI KOPYALAYIP KLASÖRE EKLETME

[sedasedadmr]

Merhabalar;

Çalışma sayfamdaki formülleri ve köprüleri almadan sayfanın kopyasının belirli bir klasöre eklenmesini istiyorum. Bu mümkün müdür? Bunun için nasıl bir kod kullanmalıyım

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Aktif_Calisma_Sayfasii_Dosya_Olarak_Kaydet()
    Dim Yol As String, Dosya_Adi As String
    
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    
    Yol = "C:\Users\Desktop\"
    Dosya_Adi = Yol & "Deneme.xlsx"
    
    ActiveSheet.Copy
    Cells.Copy
    Cells.PasteSpecial xlPasteValues
    Range("A1").Select
    
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Dosya_Adi, 51
    ActiveWorkbook.Close
    Application.DisplayAlerts = True

    Application.ScreenUpdating = 1
    Application.Calculation = -4105

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[sedasedadmr]

Hocam ben şu şekilde bir kod kullnadım . aktif sayfam Sheet2 . Rapor geliyor fakat formüller kalıyor sebebi ne olabilir*
Sub deneme()

Klasor = ThisWorkbook.Path
yer = MsgBox("Sayfada eğer makro varsa silmek istiyormusunuz.?", vbYesNo + vbInformation, " Makro silme penceresi")

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 2 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
dosya_adi = fL.GetBaseName(ThisWorkbook.Name)
uzanti = fL.GetExtensionName(ThisWorkbook.Name)

sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Günlük Rapor"
For i = 2 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Sheets(i).Name).Cells.Copy
ActiveWorkbook.Sheets(Sheets(i).Name).Range("A1:T10").PasteSpecial Paste:=3
ActiveWorkbook.Sheets(Sheets(i).Name).Select
Range("A2:T10").Select
ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next



ActiveWorkbook.Sheets(Sheets(1).Name).Select
ActiveWorkbook.SaveAs Klasor & "\" & deger
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger


End Sub

 

[Korhan Ayhan]

Bu tarz işlemlerde benim yaptığım gibi önce hesaplama yöntemini ELLE şekliden ayarlamanızda fayda var.

Application.Calculation = -4135


Ek olarak sorunun ne olduğunu anlayabilmemiz için uygulama yaptığınız dosyanızı paylaşırsanız inceleyip sorunu tespit etme şansımız olabilir.

 

[sedasedadmr]

Bu tarz işlemlerde benim yaptığım gibi önce hesaplama yöntemini ELLE şekliden ayarlamanızda fayda var.

Application.Calculation = -4135


Ek olarak sorunun ne olduğunu anlayabilmemiz için uygulama yaptığınız dosyanızı paylaşırsanız inceleyip sorunu tespit etme şansımız olabilir.

hocam belki arayan olur aynı şeyi yardımcı olmak adına yazıyorum. bütün formülerin sonuna silmesini istediğim sayfayı silmesi kodunu ekledikten sonra istediğim gibi çalışmaya başladı.
Worksheets("SHEET1").Delete

 

[sedasedadmr]

Sub deneme()

Klasor = ThisWorkbook.Path

With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
git = ActiveSheet.Name

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
r = 1
If Sheets(i).Name = "ÖNBİLGİ" Then
r = 0
End If

If r = 1 Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If

Next i
Sheets(myArray).Select
Sheets(myArray).Copy


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
Dosya_Adi = fL.GetBaseName(ThisWorkbook.Name)
uzanti = fL.GetExtensionName(ThisWorkbook.Name)
sat = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files.Count + 1

deger = "Günlük Rapor"
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets("Günlük Rapor").Cells.Copy
ActiveWorkbook.Sheets("Günlük Rapor").Range("A1:T10").PasteSpecial Paste:=3

ActiveWorkbook.Sheets("Günlük Rapor").Select
ActiveWorkbook.Sheets("Günlük Rapor").Cells.FormatConditions.Delete

Range("A1:T10").Select
ActiveSheet.DrawingObjects.Delete
Application.CutCopyMode = False
Next


Application.DisplayAlerts = False
Worksheets("SHEET1").Delete

ActiveWorkbook.Sheets("Günlük Rapor").Select
ActiveWorkbook.SaveAs Klasor & "\" & deger
ActiveWorkbook.Close SaveChanges:=False
Sheets(git).Select
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
MsgBox Klasor & deger & Chr(10) & Chr(10) & _
"Kayıt yapıldı", vbInformation, deger


End Sub