Farklı xls dosyalarını tek bir shette alt alta birleştirme

[By.TRabZonLutm]

Ağ ortamnında kodu F8 tuşu ile adım adım çalıştırıp test edebilirsiniz. Başkada yapabileceğim birşey yok maalesef.

Dosya = Dir(Kaynak_Klasör & "\*.xls") olan bölümü Dosya = Dir(Kaynak_Klasör & "\*.xls*") olarak değiştirdim düzeldi hocam

Tek sıkıntı şu, mevcut durumda dizin seçmek çok zor bir sürü klasöre girip seçmek zorunda kalıyorum. Aşağıdaki görünümü aktif edemez miyiz, uygulamak istediğimiz klasöre çok daha hızlı erişilir. (Görsel örnektir)

 

[Korhan Ayhan]

Bu linkte sabit bir klasörün seçilebilmesi için seçenek önerisinde bulunulmuş. Bende (işyerinde) denediğimde çalışmadı. Sizde deneyin belki sizde çalışır.

klasör seçerek adresi textboxa alma

Merhaba Arkadaşlar Klasör çalışmasını sayın leventm'in hazırladığı bir dosyadan aldım. Ancak ben daha farklı bir şey yapmak istiyordum ve tahmin edeceğiniz gibi beceremedim. Yapmak istediğim sorgu formundaki "klasör aç" tuşuna bastığınızda "kaydetmek istediğiniz klasörü seçin" penceresi...

www.excel.web.tr

Alternatif olarak dosya yolu belli ise kod içine yol tanımı yapılarak direkt o klasörde işlem yaptırılabilir.

 

[By.TRabZonLutm]

Bu linkte sabit bir klasörün seçilebilmesi için seçenek önerisinde bulunulmuş. Bende (işyerinde) denediğimde çalışmadı. Sizde deneyin belki sizde çalışır.

klasör seçerek adresi textboxa alma

Merhaba Arkadaşlar Klasör çalışmasını sayın leventm'in hazırladığı bir dosyadan aldım. Ancak ben daha farklı bir şey yapmak istiyordum ve tahmin edeceğiniz gibi beceremedim. Yapmak istediğim sorgu formundaki "klasör aç" tuşuna bastığınızda "kaydetmek istediğiniz klasörü seçin" penceresi...

www.excel.web.tr

Alternatif olarak dosya yolu belli ise kod içine yol tanımı yapılarak direkt o klasörde işlem yaptırılabilir.

Dosya yolu sabit değil normalde ama daha kolay olacaksa o klasörde çalışırım hocam

 

[Karakus4435]

Merhaba,

Aşağıdaki kodu boş bir excel kitabına uygulayın.

Kodu çalıştırdığınızda seçtiğiniz klasör altında yeni bir excel sayfası oluşturulur ve içine klasör altındaki dosyaların ilk sayfalarındaki veriler alt alta aktarılır.

Yeni excel dosyası "Dosya_gg_aa_yyyy_ss_dd_nn" ismi ile kayıt edilir. Kırmızı bölüm günün tarihi ve saatidir.

Option Explicit

Sub DOSYALARDAN_VERİ_AL()
    Dim K1 As Workbook, K2 As Workbook
    Dim K3 As Workbook, S1 As Worksheet
    Dim X As Integer, Satır As Integer, Son_Satır As Long
    Dim Klasör As Object, Kaynak_Klasör As String, Dosya As String
  
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Kaynak dosyaları içeren klasörü seçiniz...", 50, &H0)
  
    If Klasör = "Masaüstü" Or Klasör = "Desktop" Then
        Kaynak_Klasör = Environ("UserProfile") & "\Desktop\"
    ElseIf Not Klasör Is Nothing Then
        Kaynak_Klasör = Klasör.Items.Item.Path
    Else
        MsgBox "İşleme devam edebilmek için klasör seçimi yapmalısınız!" & Chr(10) & _
        "İşleminiz iptal edilmiştir.", vbCritical
        Exit Sub
    End If
  
    On Error Resume Next
  
    Set K1 = ThisWorkbook
    Set K2 = Workbooks.Add(1)
    Dosya = Dir(Kaynak_Klasör & "\*.xls")
    Satır = 2
  
    Application.ScreenUpdating = False
  
    Do
        If Dosya <> "" And Dosya <> K1.Name And InStr(1, Dosya, "Dosya") = 0 Then
            DoEvents
            Application.DisplayAlerts = False
            Set K3 = Workbooks.Open(Kaynak_Klasör & "\" & Dosya, False, False)
            Application.DisplayAlerts = True
            Set S1 = K3.Sheets(1)
          
            Son_Satır = S1.Cells(Rows.Count, 1).End(3).Row
            S1.Range("A2:AA" & Son_Satır).Copy _
            K2.Sheets("Sayfa1").Range("A" & Satır)
            Satır = K2.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row + 2
          
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
  
    K2.Sheets("Sayfa1").Cells.EntireColumn.AutoFit
    K2.SaveAs (Kaynak_Klasör & "\Dosya_" & Format(Now, "dd_mm_yyyy_hh_mm_ss"))
    K2.Close True
  
    Set K1 = Nothing
    Set K2 = Nothing
    Set K3 = Nothing
  
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Çok Teşekkür ederim ellerinize Sağlık beni büyük bir yükten kurtardınız. Allah razı olsun