• DİKKAT

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

Kitaplar arası sayfa aktarımı

B

bydogannn67

Altın Üye
Katılım
6 Ocak 2016
Mesajlar
226
Excel Vers. ve Dili
2010 türkçe
Merhabalar Kolay Gelsin,

İki çalışma kitabı arasında şu şekilde aktarma yapsın istiyorum

1- birici eski çalışma kitabı olsun ikinci güncel çalışma kitabı olsun

2- Makrolar ve formlar kalıcak şekilde

3- ikinci çalışma kitabında "AKTARMA" isimli Gizli sayfanın içinde A1 hücresinde "DOĞRU" yazıyosa

4- birinci eski çalışma kitabında kendi bulunduğu çalışma sayfalarının hepsini silecek

5- ikinci güncel çalışma kitabının sayfalarını eski çalışma kitaba aktaracak
 
Sayın bydogannn67 konularınızı devamlı dosya destekli yaparsanız daha çok ilgi olur.
 
tabiki hocam dosyaları ekledım

kullanıcı ADMİN

şifre 123456
 

Ekli dosyalar

  • 1.xls
    1.xls
    1 MB · Görüntüleme: 7
  • 2.xls
    2.xls
    1 MB · Görüntüleme: 4
Bir şeyler uyarlamaya çalıştım inceleyiniz.
 

Ekli dosyalar

Hocam elinize sağlık gece gece uğraşmışınız çok sağolun :)

Şöyle bi uyarlama yapabilirmiyiz peki

Aktarılacak dosyanın ismi ve yeri belli olmasa butona bastığımızda pencere açıp aktaracımız dosyayı seçsek

daha kullanışlı olucak sanki :)
 
Olabilir ancak boş bir vakit bulmam lazım. Diğer açtığınız konular çözüme ulaştıysa sayfanın üst kısmında konu araçları seçeneğinden kitleyiniz. Lazım olacak olursa aynı yerden açıp devam edebilirsiniz.
 
Tamamdır hocam hemen ilgileniyorum musait bi zamanınızda bakabilirseniz sevinirim :)
 
bydogannn67' Alıntı:
Hocam elinize sağlık gece gece uğraşmışınız çok sağolun :)
Şöyle bi uyarlama yapabilirmiyiz peki
Aktarılacak dosyanın ismi ve yeri belli olmasa butona bastığımızda pencere açıp aktaracımız dosyayı seçsek
daha kullanışlı olucak sanki :)
Genişletmek için tıkla ...

Daha kullanışlı olabilir belki ancak aktarılacak çalışma kitabı yada kitaplarının sayfa isimleri aynı olmazsa sıkıntılı olur. Yani aktarılacak örnekteki 2.xls gibi olursa olur değilse benim boyumu aşar.
 
Hocam ben işimize yarıyacak iki örnek buldum ama kendıme uyarlıyamadım sizin incelediğinizde üstesinden kalkabileceğinizi düşünüyorum
 

Ekli dosyalar

Halit bey'in katkıları ile hazırlanmış dosyayı inceler misiniz.
16.03.2016 GÜNCELLENDİ
 

Ekli dosyalar

Son düzenleme:
Hocam ilginize alakanıza çok teşekkür ederim sizler sayesinde haftalarca uğraşacığımız çalışmalarda bize yol gösterici oluyorsunuz emeği geçenlere çok teşekkürler

Fakat 1.çalışma kitabından 2. çalışma kitabındaki verileri 1.kitaba taşırken 1.çalışma kitabının sayfaları silinmesi gerekmezmi :)
 
Birinci kitabı açın sayfa aktar sil butonu ile ilk açılışta evet derseniz zaten siliyor. daha sonra açılacak userformda dosya seç ile 2.xls yi bulup istediğiniz sayfaları tek seçerek yada grup seçerek sayfa aktar ile aktaracaksınız. silmek içinde yine tek yada grup seçtikten sonra sayfa sil ile silebilirsiniz.
 
Dediğiniz gibi yaptım hocam ama olmadı yaptığım adımları resım olarak kayıt ettım inceyebilirmisiniz
 

Ekli dosyalar

Dosya aktarmada sıkıntı var nedeni dosyayı seçince ne kadar sayfa varsa görüyorsunuz hepsini seç deyincede 1.xls deki dosyada olan aynı sayfalarıda alıyorsunuz. 2.xls den başka dosyalarınız varsa (sayfa yapıları 2.xls ile ayı) çözüm yolu bulunabilir belki ama farklı yapıdaysa şimdilik elle seçerek aktarmak en iyisi. Userform11 içindeki kodların tamamını silip aşağıdaki kodu ekleyin. Otomatik silme ve gereksiz uyarılar iptal edildi.
Kod: 
Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub
Private Sub CommandButton1_Click()
ListBox1.Clear
Dosya_Yolu = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*") ', Title:="Choose Files", MultiSelect:=True)
If Dosya_Yolu = False Then
MsgBox "Dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)
uzanti = fs.GetExtensionName(Dosya_Yolu)
If aranan_Uzanti = "xlam" Then
If uzanti = "xls" Or uzanti = "xlsm" Or uzanti = "xlsx" Or uzanti = "xlsb" Then
Else
GoTo atla1
End If
End If
If aranan_Uzanti = "xla" Then
If uzanti <> "xls" Then
GoTo atla1
Else
End If
End If
Label1 = Dosya_Yolu
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
If uzanti = "xls" Then
Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & Dosya_Yolu & ";"
Else
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
End If
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
sat1 = Val(ListBox1.ListCount)
ListBox1.AddItem
ListBox1.List(sat1, 0) = Left$(son1, Len(son1) - 1)
End If
End If
End If
End If
End If
Next
Set Data = Nothing
Set Katalog = Nothing
atla1:
End Sub

Private Sub CommandButton2_Click()
Dim myArray() As Variant
Dim i As Integer
Dim yer
son = 0
If Label1 = "" Then
MsgBox "kopyası alınacak dosyayı seçmediniz.?", vbInformation, "DİKKAT"
Exit Sub
Else
End If
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks.Open(Label1)
veri_dosya_adı = ActiveWorkbook.Name
n = 0
For i = ListBox1.ListCount To 1 Step -1
If ListBox1.Selected(i - 1) = True Then
ReDim Preserve myArray(n)
myArray(n) = ListBox1.List(i - 1, 0)
n = n + 1
End If
Next
Sheets(myArray).Select
Sheets(myArray).Copy After:=Workbooks(dosya_adı).Sheets(4)
Label1 = ""
ActiveWindow.WindowState = xlMaximized
MsgBox "işlemi tamanlandı"
End Sub

Private Sub CommandButton3_Click()
Dim say
say = 0
Dim syf As Worksheet
For Each syf In Worksheets
If syf.Name <> "GİRİŞ" And syf.Name <> "LİSTE" And syf.Name <> "YAZDIR" And syf.Name <> "Sayfa1" Then
Else
say = say + 1
End If
Next
If say <= 0 Then Exit Sub
For a = say To 1 Step -1
If ListBox1.Selected(a - 1) = True Then
sayfa = ListBox1.List(a - 1, 0)
Application.DisplayAlerts = False
Sheets(sayfa).Delete
ListBox1.RemoveItem a - 1
End If
Next
End Sub

Private Sub UserForm_Initialize()
Dim sor As Integer
ListBox1.Clear
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1
Dim syf As Worksheet
For Each syf In Worksheets
    If syf.Name <> "GİRİŞ" And syf.Name <> "LİSTE" And syf.Name <> "YAZDIR" And syf.Name <> "Sayfa1" Then
        ListBox1.AddItem syf.Name
    End If
Next
End Sub
 
Hocam çalışma Kitabı 1. aktarma işleminden önce bütün kendi sayfalarını silmesi gerek :)
 
Tekrar düzenleme yapınca eklerim.
 
#12 Nolu mesajdaki dosya güncellendi.
 
Hocam günaydınlar

Başarılı bir çalışma olmuş teşekkürler bide şöyle bişi ekleme şansımız varmıdır hocam

çalışma kitabı 2 de AKTARMA sayfası içinde A1 hücresine bakıp doğru yazıyosa aktarma işlemini yapıcak eğer farklı bir çalışma kitabı seçilirse aktarma işlemi yapmıyacak hata ekranı vericek
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst