• DİKKAT

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

Tüm Sayfadaki Verileri Aktar (Bir Çalışma Kitabında Topla)

U

Utekiner

Katılım
9 Haziran 2019
Mesajlar
221
Excel Vers. ve Dili
Office 2016 Eng.
Merhaba;


1 - 2 - 3 -4 - 5 ..... adında ayrı ayrı çalışma kitaplarım bulunmaktadır. Şu anda tek tek dosyaları açarak Sayfa1 deki bilgileri kopyala yapıştır kullanarak yeni sayfaya aktarıyorum. Ne yazık ki uzun zamanlarımı alıyor.

Yapmak istediğim yeni çalışma kitabının içerisinde "1-2-3-4-5-...." Çalışma kitaplarının Sayfa1' e ait tüm verilerinin (Satır/Sütunların) Çalışma Kitabı ismi ile birlikte aktarmak istiyorum.

Forumda bir çok örneği inceledim ama maalesef benzer işlem bulamadım. Yardımcı olabilir misiniz.

kbaLAH.jpg
 
Merhaba,
Birleştirmek istediğiniz dosyaları bir klasör içine yerleştiriniz. Bir dosyaya aşağıdaki makroyu koyup dosyaların bulunduğu klasöre kaydediniz. Sonra da dosyayı açıp makroyu çalıştırınız.
Kod: 
Sub buklasordekiexceldosyalarınıBirleştir()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
yol = ThisWorkbook.Path
ad = ThisWorkbook.Name
ayrac = Application.PathSeparator
dosya = Dir(yol & ayrac & "*.xls")
      Do While dosya <> ""
      If dosya <> ad Then
        Workbooks.Open yol & ayrac & dosya
        Dim sayfa As Worksheet
        For Each sayfa In Workbooks(dosya).Worksheets
        sadi = sayfa.Name
        Workbooks(ad).Activate
        Workbooks(ad).Sheets.Add After:=Sheets(Sheets.Count)
        Workbooks(dosya).Worksheets(sadi).Range("A:Z").Copy
        Workbooks(ad).Sheets(Sheets.Count).Paste
        Next
      Workbooks(dosya).Close
      End If
        dosya = Dir()
      Loop
Dim YeniSayfa As Worksheet
Dim SayfaSay
SayfaSay = Worksheets.Count
Set YeniSayfa = Worksheets.Add(after:=Worksheets(SayfaSay))
With YeniSayfa
For i = 1 To SayfaSay
Worksheets(i).UsedRange.Copy .Range("A" & IIf(i = 1, 1, .UsedRange.Rows.Count + 1))
Next
End With
Application.ScreenUpdating = False
Application.DisplayAlerts = True
End Sub
İyi çalışmalar
Not: Makro sitedeki üstatlar tarafından hazırlanmıştır
 
Sn. @Tevfik_Kursun Bey kodları yazandan Allah razı olsun. Süper çalışıyor. Paylaştığınız için teşekkür ederim.

Şu şekilde iki talebim olması durumunda kodlarda neleri revize etmek gerekir.
- Aktardığı Çalışma Kitabının Adını Yazması, (1 - 2 - 3 ...)
- Sadece Sayfa1 in A ve B sütunlarına ait bilgiler,
 
Merhaba,
Dosyanın adını Sayfa1 yerine yazın istediğiniz olur.
Sadece A ve B sütunu lazım diğer sütunları istemiyorum diyorsanız o yapılabilir.
İyi çalışmalar
 
Merhaba,

Açık olan çalışma kitabında kapalı dosyadaki çalışma Kitabı isimleri mevcut ise ilk mesajdaki paylaşılan resim şeklinde kod revizesi nasıl olmalıdır. Teşekkürler.
 
Merhaba,
Aynı isimli sayfa yeniden açılır mı? Olmaz o. Başına ya da sonuna ek konamaz mı, konur, sıralanmaz mı, sıralanır. Bu başladı mı, sonu gelmaz.
İyi çalışmalar
 
Tevfik Bey,

Aynı isimli sayfanın açılmasını istemiyorum. Açık olan sayfanın ismi ile kapalı kitabının adına göre veri aktarabilir mi. Bunu sormuştun.
 
Örnek bir kaç tane kapalı dosya bir klasöre koyunuz,Ana dosyayıda oraya koyunuz sıkıştırıp ekleyiniz.:cool:
 
Utekiner' Alıntı:
@Orion1 Bey örnek ektedir.

Örnek Dosya
Genişletmek için tıkla ...
Dosyanız linktedir.:cool:

DOSYAYI INDIR

Kod: 
Sub aktar_59()
Dim sh As Worksheet, con As Object, rs As Object, i As Integer
Set con = CreateObject("Adodb.connection")
Set rs = CreateObject("adodb.recordset")
For i = 2 To ThisWorkbook.Worksheets.Count
    Set sh = Sheets(i)
    sh.Range("A:B").ClearContents
    If Dir(ThisWorkbook.Path & "\" & i - 1 & ".xlsx") <> "" Then
    
        con.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
                ThisWorkbook.Path & "\" & i - 1 & ".xlsx;extended properties=""excel 12.0;hdr=no""")
        rs.Open "select * from [Sheet1$A:B];", con, 1, 1
        sh.Range("A2").CopyFromRecordset rs
        rs.Close: con.Close
        sh.Range("B:B").NumberFormat = "0"
    End If
Next i
Set rs = Nothing: Set con = Nothing
MsgBox "İşlem tamamdır."
End Sub
 
Sn. @Orion1 Bey paylaşmış olduğunuz kodlar için öncelikle çok teşekkür ederim.

Kapalı sayfadaki bilgileri aktarıyor ama Kapalı dosyanın A1 sütunundaki bilgiyi Açık dosyanın A2 sütununa aktarmış
Birde Kapalı dosyanın içerisindeki sayfanın tüm bilgilerini aktarmak istersem eğer (Tüm Satır/Sütun) kodun hangi bölümlerinde revize etmek gerekecek.
 
başlık yazılmasın istersen kodu aşağıdaki gibi yapınız.:cool:
Rich (BB code): 
rs.Open "select * from [Sheet1$A2:B65536];", con, 1, 1
hepsini çekmek için;:cool:
Rich (BB code): 
rs.Open "select * from [Sheet1$];", con, 1, 1
 
Öncesinde sütunları temizlemeyi unutmayın.:cool:
 
Hocam teşekkür ederim tüm bilgilendirme için. Kusura bakmayın gece gece sizleri uğraştırıyorum.

Kod: 
sh.Range("A2").CopyFromRecordset rs
A2 - A1 yaptım düzeldi.

Açık dosyadaki 1-2-3-4-.... oluşan tüm sayfalarının içerisindeki bilgileri silmek için bir kod eklenebilir mi. Ayrı bir buton. (A1 Başlık sütunları hariç)
 
Onu zaten yaptım.Aktarmadan önce siliyor.:cool:
Rich (BB code): 
Sub aktar_59()
Dim sh As Worksheet, con As Object, rs As Object, i As Integer
Set con = CreateObject("Adodb.connection")
Set rs = CreateObject("adodb.recordset")
For i = 2 To ThisWorkbook.Worksheets.Count
    Set sh = Sheets(i)
    sh.Range("A:B").ClearContents
    If Dir(ThisWorkbook.Path & "\" & i - 1 & ".xlsx") <> "" Then
   
        con.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
                ThisWorkbook.Path & "\" & i - 1 & ".xlsx;extended properties=""excel 12.0;hdr=no""")
        rs.Open "select * from [Sheet1$A:B];", con, 1, 1
        sh.Range("A2").CopyFromRecordset rs
        rs.Close: con.Close
        sh.Range("B:B").NumberFormat = "0"
    End If
Next i
Set rs = Nothing: Set con = Nothing
MsgBox "İşlem tamamdır."
End Sub
 
B Fiş No - C Cari Kod - E Tarih sütunundaki başlıkları getirmemesi sebebi ne olabilir.

rs.Open "select * from [Sheet1$A:B];", con, 1, 1 Sildim.
rs.Open "select * from [Sheet1$];", con, 1, 1 Ekledim.
 
Alternatif;

Kod: 
Option Explicit

Sub Dosyalardan_Veri_Al()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet
    Dim Yol As String, Dosya As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set K1 = ThisWorkbook
    Yol = K1.Path & Application.PathSeparator
    
    Dosya = Dir(Yol & "*.xlsx")
    
    While Dosya <> ""
        On Error Resume Next
        Set S1 = Nothing
        Set S1 = K1.Sheets(Replace(Dosya, ".xlsx", ""))
        On Error GoTo 0
    
        Set K2 = Workbooks.Open(Yol & Dosya, 0, 0)
        Set S2 = K2.Sheets(1)
    
        If Not S1 Is Nothing Then
            S2.Range("A:B").Copy S1.Range("A:B")
        Else
            K1.Sheets.Add , K1.Sheets(K1.Sheets.Count)
            Set S1 = K1.Sheets(K1.Sheets.Count)
            S1.Name = Replace(Dosya, ".xlsx", "")
            S2.Range("A:B").Copy S1.Range("A:B")
        End If
        
        K2.Close 0
        Dosya = Dir
    Wend
    
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub
 
Sn. @Korhan Ayhan Bey çok teşekkür ederim alternatif paylaşmış olduğunuz kodlar için süper olmuş parmaklarınız dert görmesin.

Kısaca size de sorsam yazmış olduğunuz kodlarda tüm sayfaların bilgileri aktarmak istersem eğer nerede revize yapılması gerekir.
 
Aşağıdaki gibi kullanabilirsiniz.

Kod: 
Option Explicit

Sub Dosyalardan_Veri_Al()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet
    Dim Yol As String, Dosya As String
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set K1 = ThisWorkbook
    Yol = K1.Path & Application.PathSeparator
   
    Dosya = Dir(Yol & "*.xlsx")
   
    While Dosya <> ""
        On Error Resume Next
        Set S1 = Nothing
        Set S1 = K1.Sheets(Replace(Dosya, ".xlsx", ""))
        On Error GoTo 0
   
        Set K2 = Workbooks.Open(Yol & Dosya, 0, 0)
        Set S2 = K2.Sheets(1)
   
        If Not S1 Is Nothing Then
            S2.Cells.Copy S1.Cells
        Else
            K1.Sheets.Add , K1.Sheets(K1.Sheets.Count)
            Set S1 = K1.Sheets(K1.Sheets.Count)
            S1.Name = Replace(Dosya, ".xlsx", "")
            S2.Cells.Copy S1.Cells
        End If
       
        K2.Close 0
        Dosya = Dir
    Wend
   
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst