Sütunlaradaki isme göre ilgili kitaba aktarma

[byysmn]

A sütunundaki satırların isimlerine göre ayrı kitaplara (a sütunundaki veriler ile aynı isimdeki çalışma kitabına) aktarmasını istiyorum.


Ilginize teşekkürler

 

[Orion1]

Kitapların adlarına .(nokta) koyduğunuz için sorun çıkarabilir.Bu yüzden hiç uğraşmaya başlamadım bile.
Aşağıdaki karakterler yasaktır.
31 karakteri geçemez.
Boş olamaz.
: \ / ? * [ ] işaretleri olamaz

 

[byysmn]

karakterleri düzelttim

hocam karakterleri düzellitm tekrar göjnderdim. yardımcı olursanız sevinirim.

 

[Orion1]

Sayfa adlarında boşluk bırakmayın.1. GRUP adında bir boşluk var bunları birleştirin boşluk olmasın.Yaptığım kodlar bu yüzden hata ve5rdi.Epey uğraştım hatatyı bulmak için .Ben size boşluk bırakmayın düzeltin diye uyarmıştım.
Bende ki klasördeki sayfa adlarındaki boşluğu kaldırdım.Şimdi çalışıyor.Sizde sayfa adlarında 1. GRUP olanını boşluğu kaldırıp.1.GRUP yapın.Kodlar kusursuz çalışıyor.Dosyanız diğer dosyalarla ayni klasörde olamalı.1.GRUP isimde sayfası olmayan ve 1.GRUP sayfası olupta 36 sütunu olmayan dosya (sizin çalıştığınız dosya haricinde) klasör içinde dosya varsa o dosyaları oradan almalısınız.
Dosya ektedir.

Sub dosyalara_aktar()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim fso As Object, dosyalar, dosya, uzanti, Bolge As String
Dim i  As Byte, k As Range, adr As String
If MsgBox("1.grup sayfasındaki verileri klasörün içinde bulunan " _
& "diğer dosyalara aktarmak istiyormusunuz?", vbYesNo, "EVREN") = vbNo Then Exit Sub
Sheets("1. grup").Select
Set fso = CreateObject("scripting.FileSystemObject")
Set dosyalar = fso.GetFolder(ThisWorkbook.Path).Files
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
For Each dosya In dosyalar
    If dosya.Name <> ThisWorkbook.Name Then
        uzanti = "." & fso.getextensionname(dosya)
        Bolge = Left(dosya.Name, Len(dosya.Name) - Len(uzanti))
        conn.Open "Provider=Microsoft.Jet.oledb.4.0;Data Source=" & _
        dosya & ";Extended Properties=""Excel 8.0;hdr=Yes;"""
        rs.Open "Select * from [1.GRUP$];", conn, adOpenDynamic, adLockOptimistic
        Set k = Range("A2:A" & Cells(65536, "A").End(xlUp).Row).Find(Bolge, , xlValues, xlWhole)
        If Not k Is Nothing Then
            adr = k.Address
            Do
                rs.AddNew
                For i = 1 To 36
                    rs(i - 1).Value = Cells(k.Row, i).Value
                Next
               Set k = Range("A2:A" & Cells(65536, "A").End(xlUp).Row).FindNext(k)
            Loop While Not k Is Nothing And k.Address <> adr
            rs.Update
        End If
        rs.Close: conn.Close
      End If
Next
Set rs = Nothing: Set conn = Nothing
MsgBox "Bilgiler Dosyalara Aktarıldı.", vbOKOnly + vbInformation, "evrengizlen@hotmail.com"
End Sub

 

[byysmn]

hocam çok teşekkür ederim

 

[Orion1]

hocam çok teşekkür ederim

Rica ederim.

 

[byysmn]

eksik kalanlar

evren hocam şöyle bir sorun oldu
1. alttoplamları almıyor alması gerekiyor.
2. sayfalandırmayıda almıyor. mesela 2. gruplara göre sayfalandırmaka istiyorum.
3. satırları bir öncekinin altına ekliyor. eklemesin başlığın altına yapıştırsın.
4. klasördeki çalışma kitaplarını şifrelemek isityorum şifreliykende aktarabilirmiyiz.

ilginizden dolayı teşekkür ediyorum.

 

[Orion1]

Benim yazdığım kodlar Kapalı dosyalara veritabanına kayıt şeklindedir.Bu kodlar bir veri tabaınına davranıldığı gibi davranıyor.Öyle copy paste yapayım diyemezsiniz.Alt toplam içinde en sona bir sütun klerseniz oraya alt toplamı yazabilirsiniz.Ama sütunların en sonunda olur.
Sayfalara aktarmak için ise bir form yapılarak seçenek butonu kouyarak istediğiniz sayfaya aktarma işini yapabailir.
Veritabanı mantığı ile en son satıra eklenir veriler.
Şifre koyulabilir.
Sizin istekleriniz birebir yerine getirmek için dosyaları kodlarla açıp verielri girip sonra kod ile tekrar kapatmak şeklinde olur.Ama daha öncedende açık bir dosya varsa hata oluşur.Hemde daha yavaş çalışır.
Bu sistemde kayıt için başka arkadaşlardan yardım alın.Ben size yardım hakkımı dı-oldurdum.Kodların hepsi değişecek çünkü.
Aslında onları veri tabanı olarak kullanıp verileriniz başka bir dosya ya çekip veya userforma istediğinz işlemleri rahatlıkla yapabilirsinzi:Ama siz veri tabanı manıtğını kavramadığınız için bunu yapamazsınz.Hep excelin hemen oracıkta üstünde biçimlendirme hücre birleştirme falan filan yapıyorsunuz.
Siz yinede başka bir arkadaşatan yardım alın.:cool.

 

[byysmn]

ilginizden dolayı teşekkür edirim. hayırlı günler kolay gelsin