birden fazla kapalı dosyadan kopyalanan verileri yine kapalı dosyaya aktarmak

caytug · 17 Aralık 2020

Sayın korhan, kaynak dosyalarımda 17 adet (01-dosyaadı, 02-dosyaadı, 03-dosyaadı) şeklinde klasörde sıralı, Onlarıda diyalog penceresinden bulunduğu klasörü seçerek dosyaadı alfabetik sırayla işlem yapabilirmiyiz buda benim için önemli.Teşekkürler

Korhan Ayhan · 17 Aralık 2020

Deneyiniz.

C++:

Option Explicit

Sub Kapali_Dosyayi_Acarak_Veri_Aktar()
    Dim XL_App As Object, K1 As Object, S1 As Object
    Dim K2 As Object, S2 As Object, Zaman As Double
    Dim Kaynak_Dosya As Variant, X As Byte
    Dim Hedef_Dosya As Variant, Son As Long, Sutun As Byte
   
    Hedef_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
   
    If Hedef_Dosya = False Then
        MsgBox "İşleme devam edebilmeniz için verilerin aktarılacağı dosyayı seçmelisiniz!", vbCritical
        Exit Sub
    End If
   
    Kaynak_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=True)
   
    If IsArray(Kaynak_Dosya) = False Then
        MsgBox "İşleme devam edebilmeniz için aktarılacak verileri içeren dosyaları seçmelisiniz!", vbCritical
        Exit Sub
    End If
   
    Zaman = Timer
   
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
   
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
   
    Set K1 = XL_App.Workbooks.Open(Hedef_Dosya)
    Set S1 = K1.Sheets("Sayfa1")
   
    Sutun = 1
   
    For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
        Set K2 = XL_App.Workbooks.Open(Kaynak_Dosya(X))
        Set S2 = K2.Sheets("Sheet0")
       
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        S2.Range("A1:D" & Son).Copy S1.Cells(2, Sutun)
        K2.Close False
       
        Sutun = Sutun + 9
    Next
   
    K1.Close True
    XL_App.Quit
   
    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    Set XL_App = Nothing
   
    Application.Calculation = -4105
    Application.ScreenUpdating = 1
   
    MsgBox "Aktarım işlemi tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

caytug · 17 Aralık 2020

Sayın Koray,
Muhteşem olmuş ellerinize sağlık.

caytug · 24 Ekim 2021

Arkadaşlar kolay gelsin,
Sn. Korhan ayhanın yazdığı bu kod ile birden fazla kapalı dosyadan alınan 4 sütundaki verileri hedef dosyaya farklı sütunlara yazıyordu.
aynı yöntemle birden fazla kapalı dosyadan ilk 9 sütundan alınan verileri hedef dosyadaki yine ilk 9 sütuna son satırdan itibaren ekleyerek yapıştırması gerekti. yardımlarınız için teşekkürler

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Kapali_Dosyayi_Acarak_Veri_Aktar()
    Dim XL_App As Object, K1 As Object, S1 As Object
    Dim K2 As Object, S2 As Object, Zaman As Double
    Dim Kaynak_Dosya As Variant, X As Byte
    Dim Hedef_Dosya As Variant, Son As Long, Sutun As Byte

    Hedef_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)

    If Hedef_Dosya = False Then
        MsgBox "İşleme devam edebilmeniz için verilerin aktarılacağı dosyayı seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Kaynak_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=True)

    If IsArray(Kaynak_Dosya) = False Then
        MsgBox "İşleme devam edebilmeniz için aktarılacak verileri içeren dosyaları seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Zaman = Timer

    Application.ScreenUpdating = 0
    Application.Calculation = -4135

    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False

    Set K1 = XL_App.Workbooks.Open(Hedef_Dosya)
    Set S1 = K1.Sheets("Sayfa1")

    Sutun = 1

    For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
        Set K2 = XL_App.Workbooks.Open(Kaynak_Dosya(X))
        Set S2 = K2.Sheets("Sheet0")
    
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        S2.Range("A1:D" & Son).Copy S1.Cells(2, Sutun)
        K2.Close False
    
        Sutun = Sutun + 9
    Next

    K1.Close True
    XL_App.Quit

    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    Set XL_App = Nothing

    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    MsgBox "Aktarım işlemi tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Ayhan · 24 Ekim 2021

Kodun bu bölümünü revize etmeniz yeterli olacaktır.

C++:

S2.Range("A1:D" & Son).Copy S1.Cells(2, Sutun)

Yeni hali;

C++:

S2.Range("A1:I" & Son).Copy S1.Cells(2, Sutun)

caytug · 24 Ekim 2021

Sayın korhan, hedef dosyasında veriler var ve diğer dosyalardaki veriler başlık satırı hariç 2.satırdan itibaren kopyalanarak
hedef dosyasındaki son boş satırdan itibaren sırayla eklenecek.
sütun sayıları tüm dosyalarda aynı

Korhan Ayhan · 25 Ekim 2021

Başlık satırı bilgilerini kod içinden düzenlersiniz.

C++:

Option Explicit

Sub Kapali_Dosyayi_Acarak_Veri_Aktar()
    Dim XL_App As Object, K1 As Object, S1 As Object
    Dim K2 As Object, S2 As Object, Zaman As Double
    Dim Kaynak_Dosya As Variant, X As Byte
    Dim Hedef_Dosya As Variant, Son As Long

    Hedef_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)

    If Hedef_Dosya = False Then
        MsgBox "İşleme devam edebilmeniz için verilerin aktarılacağı dosyayı seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Kaynak_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=True)

    If IsArray(Kaynak_Dosya) = False Then
        MsgBox "İşleme devam edebilmeniz için aktarılacak verileri içeren dosyaları seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Zaman = Timer

    Application.ScreenUpdating = 0
    Application.Calculation = -4135

    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False

    Set K1 = XL_App.Workbooks.Open(Hedef_Dosya)
    Set S1 = K1.Sheets("Sayfa1")

    For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
        Set K2 = XL_App.Workbooks.Open(Kaynak_Dosya(X))
        Set S2 = K2.Sheets("Sheet0")
    
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        S2.Range("A2:I" & Son).Copy S1.Cells(S1.Rows.Count, 1).End(3)(2, 1)
        K2.Close False
    Next

    S1.Columns("A:C").Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart
    K1.Close True
    XL_App.Quit

    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    Set XL_App = Nothing

    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    MsgBox "Aktarım işlemi tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

caytug · 25 Ekim 2021

Sayın korhan,
kaynak dosyalardaki verileri hedef dosyasına 2. satırdan itibaren aktardı fakat hedef dosyasında da veriler var,
hedef dosyasındaki verilerin son satırından itibaren aktarması gerekiyor.

Korhan Ayhan · 25 Ekim 2021

Kodu revize ettim. Tekrar deneyiniz.

caytug · 25 Ekim 2021

Sayın Korhan tamamdır, yardımınız için çok teşekkür ederim.

caytug · 25 Ekim 2021

Sayın korhan,
access den aktararak aldığım excel dosyasında bazı sütunlarda alt+enter boşluğu oluşuyor,
yukarıdaki 27 nolu mesajınızdaki kodlarda hedef dosyasına kaynak dosyaları aktardıktan sonra
hedef dosyasındaki bu boşlukları kaldıran aşağıdaki makro kodlarını eklemek istiyorum,
hangi kodların arasına eklemeliyim, tahminimce kodlarda değişiklikte olması gerekecek. epey uğraştım olmadı.

Sub alt_enter_yok_et()
Dim hucre As Range

Columns("A:C").Select

For Each hucre In Selection
hucre.Value = _
Application.WorksheetFunction.Substitute(hucre.Value, _
vbLf, " ")
Next
End Sub

link_me · 25 Ekim 2021

Sayın Korhan Bey,
Güzel Bir Çalışma olmuş emeğinize sağlık bizim gibi yeni öğrenmeye çalışanlar için makro kodlarını ne işe yaradıklarını öğrenebilmek için size zahmet olmaz ise kodların yanına açıklama yazabilir misiniz?
kendi dosyalarımıza revize edebilmek adına

Korhan Ayhan · 26 Ekim 2021

@caytug,

Kodu tekrar revize ettim. Deneyiniz.

Korhan Ayhan · 26 Ekim 2021

@link_me,

Elimden geldiğince açık bir dille yazmaya çalıştım.

C++:

Option Explicit

Sub Kapali_Dosyayi_Acarak_Veri_Aktar()
    Rem Tanımlamaları yapıyoruz.
    Dim XL_App As Object, K1 As Object, S1 As Object
    Dim K2 As Object, S2 As Object, Zaman As Double
    Dim Kaynak_Dosya As Variant, X As Long
    Dim Hedef_Dosya As Variant, Son As Long
    Dim Veri As Variant, Y As Byte

    Rem Hedef dosyayı seçmek için windows sisteminin dosya seçme menüsünü kullanıyoruz. Burada kullanıcı tek dosya seçimi yapabiliyor.
    Hedef_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)

    Rem Eğer kullanıcı hedef dosya seçimini yapmadıysa bilgilendirme mesajı veriyoruz ve makroyu sonlandırıyoruz.
    If Hedef_Dosya = False Then
        MsgBox "İşleme devam edebilmeniz için verilerin aktarılacağı dosyayı seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Rem Kaynak dosyanın seçilmesi için yine windows sisteminin dosya seçme menüsünü kullanıyoruz. Burada kullanıcı çoklu dosya seçimi yapabiliyor.
    Kaynak_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=True)

    Rem Eğer kullanıcı hedef dosya seçimini yapmadıysa bilgilendirme mesajı veriyoruz ve makroyu sonlandırıyoruz.
    If IsArray(Kaynak_Dosya) = False Then
        MsgBox "İşleme devam edebilmeniz için aktarılacak verileri içeren dosyaları seçmelisiniz!", vbCritical
        Exit Sub
    End If

    Rem İşlem süresinin tespiti için bir sayaç başlatıyoruz.
    Zaman = Timer

    Rem Kullanıcı işlemler yapılırken ekran titremelerini görmesin diye ekran hareketlerini kapatıyoruz ve hesaplama yöntemini manuel olarak ayarlıyoruz.
    Application.ScreenUpdating = 0
    Application.Calculation = -4135

    Rem Hedef dosyayı ve kaynak dosyaları açmak için yeni gizli bir excel uygulaması tanımlıyoruz.
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False

    Rem Hedef dosyayı açıyoruz ve verilerin aktarılacağı sayfayı tanımlıyoruz.
    Set K1 = XL_App.Workbooks.Open(Hedef_Dosya)
    Set S1 = K1.Sheets("Sayfa1")

    Rem Seçilmiş olan kaynak dosyaları döngüye alıyoruz. Tek tek açarak içindeki verileri hedef dosyaya aktarıyoruz.
    For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
        Rem Sırayla kaynak dosyaları açıyoruz ve verilerin bulunduğu sayfayı tanımlıyoruz.
        Set K2 = XL_App.Workbooks.Open(Kaynak_Dosya(X))
        Set S2 = K2.Sheets("Sheet0")
   
        Rem Verilerin bulunduğu sayfadaki son dolu satırı tespit ediyoruz.
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
      
        Rem Verilerin bulunduğu sayfada A2:I & Son aralığındaki verileri kopyalayıp hedef dosyadaki sayfaya yapıştırıyoruz.
        S2.Range("A2:I" & Son).Copy S1.Cells(S1.Rows.Count, 1).End(3)(2, 1)
      
        Rem Kaynak dosyayı kaydetmeden kapatıyoruz.
        K2.Close False
      
        Rem Eğer birden fazla kaynak dosya seçimi yapıldıysa döngüye devam ediyoruz.
    Next

    Rem A:C sütunlarındaki verilerde ALT+ENTER varsa bunları boşluk karakteri ile değiştiriyoruz.
    S1.Columns("A:C").Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart

    Rem A:C sütunlarındaki verilerde fazla boşlukları temizliyoruz.
    Veri = S1.Range("A1:C" & S1.Cells(S1.Rows.Count, "A").End(xlUp).Row).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        For Y = LBound(Veri, 2) To UBound(Veri, 2)
            Veri(X, Y) = Application.Trim(Veri(X, Y))
        Next
    Next
    
    S1.Range("A1").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri

    Rem Hedef dosyayı içine veri aktardığımız için kayıt ederek kapatıyoruz.
    K1.Close True
  
    Rem Gizli olarak açtığımız excel uygulamasından çıkıyoruz.
    XL_App.Quit

    Rem Makro başlangıcındaki tanımlamaları hafızadan siliyoruz.
    Set S2 = Nothing
    Set K2 = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    Set XL_App = Nothing

    Rem Hesaplama yöntemini tekrar otomatik olarak ayarlayıp ekran hareketlerini aktif hale getiriyoruz.
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    Rem Makronun tamamlandığını ilişkin kullanıcıya bilgilendirme mesajı veriyoruz.
    MsgBox "Aktarım işlemi tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation

Rem Makroyu sonlandırıyoruz.
End Sub

caytug · 26 Ekim 2021

Sayın korhan, aşağıdaki satırda hata verdi.

S1.Columns("A:C").Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart

Runtime rerror '424'
Object Reguried

caytug · 26 Ekim 2021

Sayın Korhan kodların yerini aşağıdaki gibi değiştirince düzeldi, çok teşekkür ederim.

S1.Columns("A:C").Replace What:=Chr(10), Replacement:=" ", LookAt:=xlPart
K1.Close True
XL_App.Quit

Korhan Ayhan · 26 Ekim 2021

Doğru tespit etmişsiniz. Denemeden yazmıştım. Hatalı satıra yazmışım. Bende kodu tekrar revize ettim.

caytug · 28 Ekim 2021

Sayın korhan kodlara açıklama koymanız çok isabetli olmuş elinize sağlık.
müsait olduğunuzda,
S1.Columns("A:C") sütunlarına uygulanacak fazladan boşlukları kaldıracak Trim kodları yazarsanız memnun olurum.Teşekkürler

Korhan Ayhan · 28 Ekim 2021

#34 nolu mesajımda ki kodu revize ettim. Deneyiniz.

caytug · 28 Ekim 2021

Sayın korhan ellerinize sağlık teşekkür ederim.

birden fazla kapalı dosyadan kopyalanan verileri yine kapalı dosyaya aktarmak

caytug

Korhan Ayhan

Administrator

caytug

caytug

Korhan Ayhan

Administrator

caytug

Korhan Ayhan

Administrator

caytug

Korhan Ayhan

Administrator

caytug

caytug

link_me

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

caytug

caytug

Korhan Ayhan

Administrator

caytug

Korhan Ayhan

Administrator

caytug