• DİKKAT

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

Veri Kopyalama

M

Metin55

Katılım
13 Kasım 2013
Mesajlar
52
Excel Vers. ve Dili
2003
Ekte örnek dosyadaki d6:K27 hücre aralığındaki tabloyu formüller hariç biçimlenmiş hali ile masa üstüne yeni bir dosya ile nasıl kayıt yapabiliriz?.Ayrıca kaydet butonuna bastığında bize hangi isimle kayıt yapılacağına dair bir kutucuk gelip kutucuğa dosya ismini girip o isimle kayıt yaptırmak mümkünmüdür.Yardımcı olursanız memnun kalırım.Saygılar
 

Ekli dosyalar

Günadın arkadaşlar lütfen konuya yardımcı olabilirmisiniz
 
Metin55' Alıntı:
Ekte örnek dosyadaki d6:K27 hücre aralığındaki tabloyu formüller hariç biçimlenmiş hali ile masa üstüne yeni bir dosya ile nasıl kayıt yapabiliriz?.Ayrıca kaydet butonuna bastığında bize hangi isimle kayıt yapılacağına dair bir kutucuk gelip kutucuğa dosya ismini girip o isimle kayıt yaptırmak mümkünmüdür.Yardımcı olursanız memnun kalırım.Saygılar
Genişletmek için tıkla ...
. . .

Üst satırdaki A-B-C... vb. tabloda yer alan sabit veriler aktarılacak mı ?
Yoksa boş tablo halinde, biçim mi aktarılacak.

. .
 
Hüseyin bey tablodaki veriler ,biçim ve tablo aktarılacak .Formülller varsa formülsüz olarak değerler aktarılacak
 
. . .

Dosyanız ektedir.

Kod: 
Sub KOD()
Application.ScreenUpdating = False
Application.DisplayAlerts = False


Sheets("FKAYDET").Visible = True[COLOR="DarkGreen"] 'GÖSTER[/COLOR]
Sheets("FKAYDET").Range("D6:K27").Clear

Range("D6:K27").Copy

Sheets("FKAYDET").Select
Range("D6:K27").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
        
yol = ThisWorkbook.Path
[COLOR="DarkGreen"]'MASA ÜSTÜ İÇİN KENDİ BİLGİSAYARINIZA GÖRE DEĞİŞTRİNİZ ÖR;
'yol="C:\Users\Hüseyin Çoban\Desktop"[/COLOR]
ad = InputBox(" Yeni Sayfa İsmi Giriniz ")

If ad = "" Then Exit Sub

Sheets("FKAYDET").Copy
If Val(Application.Version) > 11 Then
ActiveWorkbook.SaveAs Filename:=yol & "\" & ad & ".xls", FileFormat:=xlExcel8
Else
ActiveWorkbook.SaveAs Filename:=yol & "\" & ad & ".xls"
End If
ActiveWorkbook.Close True


Sheets("Sayfa1").Select
[COLOR="DarkGreen"]'Sheets("FKAYDET").Visible = False 'GİZLE[/COLOR]

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox " B i t t i "

End Sub

. . .
 

Ekli dosyalar

Hüseyin bey çok teşekkür ederim.Tam istediğim şekilde kodlar.Sizi zahmet olmassa eğer aynı kodu ekteki örnekte veri sayfasında bulunan ComboBox.1'den sayfayı seçip (a,b,c) kaydet butonuna bastığımızda seçilen sayfanın ilgili yeri kaydet işlemi masa üstünde metin klasörürün içerisine olabilir mi?
 

Ekli dosyalar

. . .

Kod: 
Sub KOD()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

ad = InputBox(" Yeni Sayfa İsmi Giriniz ")
If ad = "" Then Exit Sub

Sheets("FKAYDET").Visible = True 'GÖSTER
Sheets("FKAYDET").Range("D6:K27").Clear

[B]syf = Sheets("Veri").ComboBox1.Text
Sheets(syf).Range("D6:K27").Copy[/B]

Sheets("FKAYDET").Select
Range("D6:K27").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
        
yol = ThisWorkbook.Path
'MASA ÜSTÜ İÇİN KENDİ BİLGİSAYARINIZA GÖRE DEĞİŞTRİNİZ ÖR;
'yol="C:\Users\Hüseyin Çoban\Desktop\ali"

Sheets("FKAYDET").Copy
If Val(Application.Version) > 11 Then
ActiveWorkbook.SaveAs Filename:=yol & "\" & ad & ".xls", FileFormat:=xlExcel8
Else
ActiveWorkbook.SaveAs Filename:=yol & "\" & ad & ".xls"
End If
ActiveWorkbook.Close True


Sheets("veri").Select
'Sheets("FKAYDET").Visible = False 'GİZLE

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox " B i t t i "

End Sub

Sayfa isimlerini almak için kodlar: Sayfa1 kod bölümüne
Kod: 
Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ComboBox1.Clear
For i = 1 To Sheets.Count
If Sheets(i).Name = "veri" Or _
Sheets(i).Name = "FKAYDET" Then
Else
ComboBox1.AddItem Sheets(i).Name
End If
Next i
End Sub

İlave: Örnek dosya eklendi.
. . .
 

Ekli dosyalar

Son düzenleme:
Hüseyin bey şöyle bir hata veriyor.Birileştirilen hücrelerin aynı boyutta olması gerekli diyor
 
. . .

#7 mesajıma örnek dosyayı ekledim. Deneyiniz. Bende hata vermedi.

. . .
 
Hüseyin bey çok teşekkür ederim.Sizden son bir ricam olacak 5.numaralı mesajınızdaki kodd şöyle bir değişiklik yapmak mümkünmüdür.Masa üsütüne kopya isminde bir klasör açacak yeni isimle kayıt yaptığımız dosyayı bu klasörün içerisine kayıt yapacak sayfanın ismide dosyanın ismi olacak
 
. . .

Hangi mesajdaki kodları kullanıyorsunuz ?
Ona göre revize edeyim.

. . .
 
. . .

Kod: 
Sub KOD()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

ad = InputBox(" Yeni Sayfa İsmi Giriniz ")
If ad = "" Then Exit Sub

sayfaismi = ActiveSheet.Name

Sheets("FKAYDET").Visible = True 'GÖSTER
Sheets("FKAYDET").Range("D6:K27").Clear

Range("D6:K27").Copy

Sheets("FKAYDET").Select
Range("D6:K27").Select
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats

yol = CreateObject("WScript.Shell").specialfolders("Desktop")
MkDir CreateObject("WScript.Shell").specialfolders("Desktop") & "\KOPYA\"

Sheets("FKAYDET").Copy
If Val(Application.Version) > 11 Then
ActiveWorkbook.SaveAs Filename:=yol & "\KOPYA\" & ad & ".xls", FileFormat:=xlExcel8
Else
ActiveWorkbook.SaveAs Filename:=yol & "\KOPYA\" & ad & ".xls"
End If

ActiveWorkbook.ActiveSheet.Name = ad
ActiveWorkbook.Close True

Sheets(sayfaismi).Select
'Sheets("FKAYDET").Visible = False 'GİZLE

Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox " B i t t i "

End Sub

. . .
 
Hüseyin bey çok teşekkür ederim.Kod tam istediğim şekilde çalışıyor.Fakat kaydet butonuna ikinci kez bastığımda hata veriyor.
 
. . .

Denemeden kod göndermem.
Verdiğim kodları eksiksiz kopyaladığınızdan,
örnek dosya veya kodlarda değişiklik yapmadığınızdan emin misiniz ?

. . .
 
Sayın Hüseyin bey son kodda tablo içerisindeki veriler kayıt yapılmıyor
 
dosyanızda hata vermedi.ama tablo içerisindeki veriler yeni kayıt sayfasında boş gözüküyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst