Sayfaları birleştiren kodlarda düzeltme

I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Merhaba iyi günler

Ekte; sayın Korhan Ayhan uzmanımızın paylaşmış olduğu, bir klasördeki sayfaları birleştiren dosya ve iki birleşecek dosya örneği vardır.

Dosyalar birleşirken 1. (birinci) satırlar aktarılmamaktadır. Kodlarda düzeltilmesini rica ederim.

Teşekkürler


İndir ornek

Dosyayı indir ornek
dosya.co
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,266
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
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 edbilmek 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 = 1
   
    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("A1: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
 
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
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 edbilmek 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 = 1
  
    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("A1: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 ...
Sağolunuz uzmanım
 
I

izcik

Katılım
18 Mayıs 2009
Mesajlar
1,184
Excel Vers. ve Dili
Excel 2016 Türkçe
İdris SERDAR' Alıntı:
.

Benim dosya ile yapılan birleştirme.

İndir Dosya Birleştirme2

Dosyayı indir Dosya Birleştirme2
dosya.co


.
Genişletmek için tıkla ...
Sayın İdris Serdar uzmanım, ilk denediğimde Excel 2010 ile denemiştim ve dosya nedense hiç çalışmamıştı.

Daha sonraki denemelerimde ise aynı dosyayı Excel 2013 ile denedim ve hiç sorunsuz çalıştı.

Farklı versiyonlardaki excel ile çıkabilecek sorunlara şahit olmuş oldum. Arada olabiliyor bu tür minik hatalar.

Fakat eğer mümkünse şöyle bir düzeltme yapabilir miyiz?

Birleştirmek için seçtiğimiz iki dosyadan birisinin ilk satırı, aktarılmıyor. Oysa aktarılması gerekir.

Bu düzeltmeyi yapabilirsek daha iyi olur.
Saygılar
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst