• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Birkaç Sayfayı Bilgisayara Kaydetme

ahmed_ummu

ahmed_ummu

Altın Üye
Katılım
28 Mart 2011
Mesajlar
777
Excel Vers. ve Dili
Excel 2010 Professional Plus 64 Bit
Merhaba arkadaşlar.

Sheets("veri").Select
ActiveSheet.Copy
Application.Dialogs(xlDialogSaveAs).Show
ActiveWorkbook.Close

Yukarıdaki kod ile "veri" sayfasını bilgisayara kaydediyorum. Bu işimi görüyordu şimdi ise "PA_EK" "PA" "LÜZUMBELGESİ" ve "MTKK" sayfalarını da kaydetmem gerekiyor.

Bu sayfaları bir kitap içine kaydedebilir miyim. Bir de kitabın adını, MTKK sayfasının B6 hücresi ile PA sayfasındaki E5 hücresindeki verileri birleştirerek, masaüstündeki "SATINAMLA" klasörüne Farklı Kaydet diyalog kutusu çıkmadan kaydedilebilinir mi. Yardımcı olursanız çok sevinirim.
 
Bu örnek üzerinden ilerlerseniz yapılır.

C#: 
Sub coklusayfakayit()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("Sheet1", "Sheet3", "Sheet5")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
   On Error Resume Next
   MkDir (yol)
   On Error GoTo 0
End If

isim = "Dosyaadi"

Application.DisplayAlerts = False
wbkopya.SaveAs yol & isim & ".xlsx"
Application.DisplayAlerts = True
wbkopya.Close
End Sub
 
Asri' Alıntı:
Bu örnek üzerinden ilerlerseniz yapılır.

C#: 
Sub coklusayfakayit()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("Sheet1", "Sheet3", "Sheet5")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
   On Error Resume Next
   MkDir (yol)
   On Error GoTo 0
End If

isim = "Dosyaadi"

Application.DisplayAlerts = False
wbkopya.SaveAs yol & isim & ".xlsx"
Application.DisplayAlerts = True
wbkopya.Close
End Sub
Genişletmek için tıkla ...

Yardımınız için çok teşekkürler sayın asri. Aşağıdaki gibi yaptım ama masaüstüne, kopyalanan sayfaların içinde bulunduğu ve yine sayfalardan bazı verilerin alınarak belirlenen bir isim ile bir kitap açıyor. Bir de boş bir "SATINALMA" klasörü açıyor. Açılan kitabı "SATINALMA" klasörünün içinde oluşturamaz mı.

Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("PA", "PA_EK", "LÜZUMBELGESİ", "MKTT")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
On Error Resume Next
MkDir (yol)
On Error GoTo 0
End If

isim = Sheets("MKTT").Range("b5").Value & " " & Sheets("MKTT").Range("b6").Value & " " & Sheets("MKTT").Range("b7").Value & " " & Sheets("MKTT").Range("b8").Value

Application.DisplayAlerts = False
wbkopya.SaveAs yol & isim & ".xlsx"
Application.DisplayAlerts = True
wbkopya.Close
 
Denemedim ama bu şekilde deneyin.

C#: 
et fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("PA", "PA_EK", "LÜZUMBELGESİ", "MKTT")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
On Error Resume Next
MkDir (yol)
On Error GoTo 0
End If

isim = Sheets("MKTT").Range("b5").Value & " " & Sheets("MKTT").Range("b6").Value & " " & Sheets("MKTT").Range("b7").Value & " " & Sheets("MKTT").Range("b8").Value

Application.DisplayAlerts = False
[B]wbkopya.SaveAs yol & "\" & isim & ".xlsx"[/B]
Application.DisplayAlerts = True
wbkopya.Close
 
Asri' Alıntı:
Denemedim ama bu şekilde deneyin.

C#: 
et fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("PA", "PA_EK", "LÜZUMBELGESİ", "MKTT")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
On Error Resume Next
MkDir (yol)
On Error GoTo 0
End If

isim = Sheets("MKTT").Range("b5").Value & " " & Sheets("MKTT").Range("b6").Value & " " & Sheets("MKTT").Range("b7").Value & " " & Sheets("MKTT").Range("b8").Value

Application.DisplayAlerts = False
[B]wbkopya.SaveAs yol & "\" & isim & ".xlsx"[/B]
Application.DisplayAlerts = True
wbkopya.Close
Genişletmek için tıkla ...

İlginize çok teşekkürler sayın Asri.

Eklediğim resimdeki gibi hata verdi.

Yardımcı olursanız bişey daha sormak istiyorum. Sayfaları kaydederken dosya türünü "Excel 97-2003 Çalışma Kitabı" olarak kaydedebilir mi.

Yardımlarının içim şimdiden teşekkürler.
 

Ekli dosyalar

  • ÖRNEK.jpg
    ÖRNEK.jpg
    354.4 KB · Görüntüleme: 3
Enteresan, kodun başını ve sonunu yapıştırmamışım.

Sizin sayfa yapınıza göre düzenlendi. Test edildi.
Office 2003 olarak kayıt yapılacak.

C#: 
Sub coklusayfakayit()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("PA", "PA_EK", "LÜZUMBELGESİ", "MKTT")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
   On Error Resume Next
   MkDir (yol)
   On Error GoTo 0
End If

isim = Sheets("MKTT").Range("b5").Value & " " & Sheets("MKTT").Range("b6").Value & " " & Sheets("MKTT").Range("b7").Value & " " & Sheets("MKTT").Range("b8").Value


Application.DisplayAlerts = False
wbkopya.SaveAs yol & "\" & isim & ".xls", FileFormat:=56
Application.DisplayAlerts = True
wbkopya.Close
End Sub
 
Asri' Alıntı:
Enteresan, kodun başını ve sonunu yapıştırmamışım.

Sizin sayfa yapınıza göre düzenlendi. Test edildi.
Office 2003 olarak kayıt yapılacak.

C#: 
Sub coklusayfakayit()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
Sheets(Array("PA", "PA_EK", "LÜZUMBELGESİ", "MKTT")).Copy
Set wbkopya = ActiveWorkbook

yol = Environ("USERPROFILE") & "\Desktop\SATINALMA"
If Not fso.FileExists(yol) Then
   On Error Resume Next
   MkDir (yol)
   On Error GoTo 0
End If

isim = Sheets("MKTT").Range("b5").Value & " " & Sheets("MKTT").Range("b6").Value & " " & Sheets("MKTT").Range("b7").Value & " " & Sheets("MKTT").Range("b8").Value


Application.DisplayAlerts = False
wbkopya.SaveAs yol & "\" & isim & ".xls", FileFormat:=56
Application.DisplayAlerts = True
wbkopya.Close
End Sub
Genişletmek için tıkla ...

Çok teşekkürler sayın Asri elinize sağlık, iyi akşamlar.
 
Sayın Asri bu makroyu kendi belgeme uyarlamaya calıstim fakat yapamadım.
Excel belgesi icindeki A,B,C,D isimli 4 sayfayı formulsüz olarak kopyalayıp aynı belgedeki MİATLI sayfası B5 hücresindeki isme göre xls formatinda tek belge olarak masaüstüne kayıt yaptırmak istiyorum. Yardimcı olabilirmisiniz.
 
Son düzenleme:
Bu şekilde dener misiniz? masa üstüne kaydedecektir.

C#: 
Sub coklusayfakayit()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
    isim = wbmevcut.Sheets("MİATLI").Range("B5").Value

    Sheets(Array("A", "B", "C", "D")).Copy
    Set wbkopya = ActiveWorkbook
    
    wbkopya.Sheets("A").Cells.Copy
    wbkopya.Sheets("A").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    wbkopya.Sheets("B").Cells.Copy
    wbkopya.Sheets("B").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    wbkopya.Sheets("C").Cells.Copy
    wbkopya.Sheets("C").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    wbkopya.Sheets("D").Cells.Copy
    wbkopya.Sheets("D").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    
    yol = Environ("USERPROFILE") & "\Desktop"
    If Not fso.FileExists(yol) Then
       On Error Resume Next
       MkDir (yol)
       On Error GoTo 0
    End If
    
    Application.DisplayAlerts = False
    wbkopya.SaveAs yol & "\" & isim & ".xls", FileFormat:=56
    Application.DisplayAlerts = True
    wbkopya.Close
End Sub
 
Merhaba arkadaşlar
Excel 2016 da hazırladığım kitapta asagidaki makro calısıyor fakat 2016 kullanan başka pc yüklediğimde makro kopyalıyor ancak farklı kaydet penceresi acılarak kaydedilecek yeri ve kitap ismini soruyor. Bu neden olabilir. Tsl ederim.

Sub coklusayfakayit_haftalık()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
isim = wbmevcut.Sheets("MİATLI").Range("F13").Value
Sheets("HAFTALIK").Unprotect Password:="55"
Sheets(Array("HAFTALIK")).Copy
Set wbkopya = ActiveWorkbook
wbkopya.Sheets("HAFTALIK").Cells.Copy
wbkopya.Sheets("HAFTALIK").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
yol = Environ("USERPROFILE") & "\Desktop"
If Not fso.FileExists(yol) Then
On Error Resume Next
MkDir (yol)
On Error GoTo 0
End If
Application.DisplayAlerts = False
wbkopya.SaveAs yol & "\" & isim & ".xls", FileFormat:=56
Application.DisplayAlerts = True
wbkopya.Close
Sheets("HAFTALIK").Protect Password:="55"
End Sub
 
fikretac' Alıntı:
Merhaba arkadaşlar
Excel 2016 da hazırladığım kitapta asagidaki makro calısıyor fakat 2016 kullanan başka pc yüklediğimde makro kopyalıyor ancak farklı kaydet penceresi acılarak kaydedilecek yeri ve kitap ismini soruyor. Bu neden olabilir. Tsl ederim.

Sub coklusayfakayit_haftalık()
Set fso = CreateObject("scripting.filesystemobject")
Set wbmevcut = ActiveWorkbook
isim = wbmevcut.Sheets("MİATLI").Range("F13").Value
Sheets("HAFTALIK").Unprotect Password:="55"
Sheets(Array("HAFTALIK")).Copy
Set wbkopya = ActiveWorkbook
wbkopya.Sheets("HAFTALIK").Cells.Copy
wbkopya.Sheets("HAFTALIK").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
yol = Environ("USERPROFILE") & "\Desktop"
If Not fso.FileExists(yol) Then
On Error Resume Next
MkDir (yol)
On Error GoTo 0
End If
Application.DisplayAlerts = False
wbkopya.SaveAs yol & "\" & isim & ".xls", FileFormat:=56
Application.DisplayAlerts = True
wbkopya.Close
Sheets("HAFTALIK").Protect Password:="55"
End Sub
Genişletmek için tıkla ...

yol dan kaynaklı bir sorun olabilir. Buradaki bilgiyi
yol = Environ("USERPROFILE") & "\Desktop"

Bu şekilde değiştirip deneyebilir misiniz.
yol ="C:\deneme"
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst