• DİKKAT

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

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

Korhan Ayhan' Alıntı:
Bütün dosyalarınızda aktarılacak sayfa adı Sheet3'mü?

Birde aktarımın nasıl olmasını istiyorsunuz?

Aktarmak istediğiniz dosyaları seçmek ister misiniz? Yoksa sabit yol tanımlayıp bu yoldaki dosyalar mı işleme alınsın?

Verilerin hepsi bir dosyada bir sayfada alt alta mı aktarılsın?
Genişletmek için tıkla ...

Hayırlı Sabahlar Hocam,

1-Bütün hepsinde sheet3 isimli klasörü aktarmak istiyorum.

2-Excel dosyalarını seçmeyeceğim, gönderdiğim örnek klasör gibi klasörleri seçip içindeki aktarmamız yeterli.

3- Evet hocam, hepsini bir sayfada alt alta aktarmak istiyorum. Eğer mümkünse de "E" kolonuna göre sıralanması sağlayabilir misiniz?
 
#61 nolu mesjımda paylaştığım dosyayı denediniz mi?
 
Hocam Günaydın

Öncelikle geçmiş bayramınızı kutlarım.

#61 nolu mesajı indiremedim. Çünkü ücretli üyelik istiyor onuda yapmak istediğim zaman işlemi tamamlayamıyorum. wetransfer link süresinin de dolması nedeniyle indiremedim.
 
Teşekkürler.. Bilmukabele..

#61 nolu mesajımda ki harici linki güncelledim. Tekrar deneyebilirsiniz.
 
çok çok çok teşekkür ederim
ellerinize emeğinize sağlık Hocam
 
Hocam merhabalar. 5 numaralı mesajdaki kodları kullanıyorum. Dosyalarım çok fazla olduğundan mıdır nedir bilemiyorum ama birleştirmede 34516. satırdan sonraya ne yaptımsa ekleme yapmıyor. Sadece oraya kadar yapıyor. Nerede hata yapıyorum acaba? Teşekkürler.
 
Tanımlama bölümünde "Integer" olan değişkenleri "Long" olarak tanımlayıp deneyiniz.
 
Korhan Ayhan' Alıntı:
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.

Kod: 
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
Genişletmek için tıkla ...

Merhaba Korhan Ayhan bey,
Yapmış olduğunuz makroda sadece ilk sheet'i alıyor.
Klasör içeriğimdeki excel dosyaları birden fazla sheet içeriyor. sadece ikinci sheet'i alması için makroyu nasıl düzenlemeliyim?

bir de makroyu çalıştırdığımda klasör içeriğindeki excel dosyalarının da kayıt tarih ve saatlerini değiştiriyor, kayıt zamanlarını değiştirmesini nasıl önleyebilirim?
 
Burada ki sayısal değer dosyanın içinde ki sayfa sırasını ifade eder.

Set S1 = K3.Sheets(1)


Siz ikinci sırada ki sayfa için 2 olarak düzenlemelisiniz.
 
yalnız şöyle bir sorunum var,
makroyu çalıştırdığımda bu şekilde bir uyarı mesajı alıyorum ve TÜMÜNE EVET diyerek geçiyorum ama her excel dosyasında soruyor.
bunu nasıl düzeltebilirim?

https://resmim.net/i/KLmpn

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(2)

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
 
Kaynak dosyalarınızda ad-tanımlama olabilir. Veriler kopyala-yapıştır yöntemi ile taşındığı için çakışma oluyordur. Bunları kontrol etmelisiniz.
 
Korhan Ayhan' Alıntı:
Ekteki dosyayı bir deneyiniz.

Harici Link (Silinebilir) ; https://we.tl/t-sBmYnHio7e
Genişletmek için tıkla ...

Kayit_Seti.Open Sorgu, Baglanti, 1, 1

veri almak istediğim dosyanın ilk sayfasının başlıkları

ADRES BİLGİLERİ TOPLU SORGULAMA SONUCU































S.No

T.C. Kimlik No

Adres No

Ülke

İl

İlçe

Bucak

Köy

Mahalle

Cadde/Sokak

Dış Kapı No

İç Kapı No

Köy Kayıt No

Taşınma Tarihi

Beyan Tarihi

Varsa Diğer Adresleri

bu şekilde ondan mı hata alıyorum
 
Hocam merhabalar peki dosyalarin icinde birden fazla sheet varsa bu durumda nasil donguye aliriz ?
 
iyi günler arkadaşlar.
korhan hocanın yazmış olduğu kod klasörün içerisinde yeni excel doyası oluşturuyor ama içi boş oluyor. benim excel sayfalarının ''sayfa 1'' değilde SBF_STK_FRMRHS_ENSONSTK_DRM_GTP şeklinde isimlendirilmiş. sayfa 1 yazan kısımları bununla değiştirdim. sonuç yine aynı oldu. yardımcı olacak arkadaşlara şimdiden teşekkür ederim.



Kod: 
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("SBF_STK_FRMRHS_ENSONSTK_DRM_GTP").Range("A" & Satır)
            Satır = K2.Sheets("SBF_STK_FRMRHS_ENSONSTK_DRM_GTP").Cells(Rows.Count, 1).End(3).Row + 2
          
            K3.Close True
            Dosya = Dir
        Else
            Dosya = Dir
        End If
    Loop While Dosya <> ""
  
    K2.Sheets("SBF_STK_FRMRHS_ENSONSTK_DRM_GTP").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
 
Yardım alabilmeniz için örnek dosyalarınızı paylaşmanız gerekir.
 
https://files.fm/u/9ggpzvftc
linki paylaştım hocam. bir klasör içerisinde bu şekilde s(1) den 850 ye kadar excel dosyası var.
sayfa isimleri hepsinde aynı. içerisindeki tablolar genişlik ve başlıklar aynı kimisi daha çok satır içerebiliyor.
ben bunların hepsini tek bir excel sayfasında alt alta almak istiyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst