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

caytug · 27 Kasım 2020

İyi günler, ekteki dosyalarda açık olan aktar.xls dosyasına konan buton yardımıyla (kapalı olan dosya1.xls ,dosya2.xls, dosya3.xls) dosyalarındaki verileri aynı anda (yine kapalı olan hedef.xlsm) dosyasındaki sarı işaretli ilgili sütunlara 2. satırlardan itibaren ayrı ayrı değer olarak yapıştırmak için vba kodu lazım. Yardımlarınız için teşekkürler

caytug · 28 Kasım 2020

cevap yokmu?

Korhan Ayhan · 29 Kasım 2020

Deneyiniz.

HEDEF dosyanızın yapısını biraz değiştirmek durumunda kaldım.

Diğer türlü kullanmak isterseniz dosyaları açarak verileri aktarmak gerekecektir.

caytug · 29 Kasım 2020

Sayın Korhan,
ilginize ve emeğinize teşekkür ederim bu şekilde işimi görmüyor, ancak dosyaları açarakta olur.

Korhan Ayhan · 30 Kasım 2020

Dosyaları gizli şekilde açarak verileri aktaran kodu deneyiniz.

#3 nolu mesajımın ekindeki dosyaları da güncelledim. Küçük bir eklemeyi atlamışım. Kullanmak isteyen olabilir düşüncesiyle güncelledim.

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 Yol As String, Kaynak_Dosya As Variant, X As Byte
    Dim Hedef_Dosya As String, Son As Long, Sutun As Byte

    Zaman = Timer

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set XL_App = CreateObject("Excel.Application")
    XL_App.Visible = False
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Hedef_Dosya = Yol & "Hedef.xlsm"
   
    Set K1 = XL_App.Workbooks.Open(Hedef_Dosya)
    Set S1 = K1.Sheets("Sayfa1")
   
    Kaynak_Dosya = Array("dosya1.xls", "dosya2.xls", "dosya3.xls")

    Sutun = 1

    For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
        Set K2 = XL_App.Workbooks.Open(Yol & 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 = xlCalculationAutomatic
    Application.ScreenUpdating = True

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

caytug · 30 Kasım 2020

Sayın Korhan,
Tam istediğim gibi olmuş,ellerinize sağlık Allah razı olsun.
dosyayı son haliyle atıyorum diğer arkadaşlarda istifade etsin.

tukayf · 30 Kasım 2020

Sn. Korhan Hocam zihninize sağlık. Dosya adı her ne olursa olsun o yolda bulunan tüm dosyalardan veri çekebilmek için kodu revize edebilir miyiz.

Korhan Ayhan · 30 Kasım 2020

@tukayf,

Hangi kodun revize olmasını talep ettiniz?

tukayf · 30 Kasım 2020

Kapalı Dosyadan Açık Dosyaya Veri Alma

İyi akşamlar, Kapal1, Kapalı2, Kapalı3 dosyalarıındaki A2:J2 arası verileri Açık dosya A2 den başlayarak alt alta buton yardımı ile kopyalamak istiyorum. Kapalı olan dosya sayısı değişken 50 - 80 arası dosya var. Dosya isimleri sabit değil ve bulunduğu klasör ismi sabit değil. Yardımlarınızı...

www.excel.web.tr

Sn. Hocam bu linkteki çözümünüz benim için ideal olanı ancak buradaki çözüm de sadece ilk satırları kopyalıyor. İstediğim şey sayfadaki bütün verilerin kopyalanması ve bittiği yerden sırasıyla diğer dosyaların devam etmesi.

Korhan Ayhan · 30 Kasım 2020

Tamam siz örnek dosyalarınızı paylaşın ona göre kodu revize edelim.

tukayf · 30 Kasım 2020

Sn. Hocam dosyalar ekte yardımcı olabilirseniz çok sevinirim. Bu şekilde 1000 den fazla dosya var. Her iki sayfaya veri çekecek kodlar farklı butonlar ile çalıştırılırsa çok sevineceğim.

Korhan Ayhan · 30 Kasım 2020

Ben verileri değer olarak aktardım. Dilenirse kopyala-yapıştır mantığı ile de alınabilir.

C++:

Option Explicit

Sub Kurs_Verilerini_Aktar()
    Dim Zaman As Double, Yol As String, Alan As Range, Son As Long
    Dim Dosya As String, S1 As Worksheet, S2 As Worksheet
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("Kurs")
   
    S1.Range("A2:D" & S1.Rows.Count).ClearContents
   
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            GetObject (Yol & Dosya)
            Set S2 = Workbooks(Dosya).Sheets(1)
            On Error Resume Next
            Set Alan = Nothing
            Set Alan = S2.Range("B37:D45").SpecialCells(xlCellTypeConstants, 23)
            On Error GoTo 0
            If Not Alan Is Nothing Then
                Son = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                S1.Range("B" & Son).Resize(Alan.Rows.Count, 3).Value = Alan.Value
                S1.Range("A" & Son).Resize(Alan.Rows.Count, 1).Value = S2.Range("B2").Value
            End If
            Workbooks(Dosya).Close 0
        End If
        Dosya = Dir
    Wend
   
    Set Alan = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

Sub Cocuk_Verilerini_Aktar()
    Dim Zaman As Double, Yol As String, Alan As Range, Son As Long
    Dim Dosya As String, S1 As Worksheet, S2 As Worksheet
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set S1 = Sheets("Çocuk")
   
    S1.Range("A2:M" & S1.Rows.Count).ClearContents
   
    Yol = ThisWorkbook.Path & "\"
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If Dosya <> ThisWorkbook.Name Then
            GetObject (Yol & Dosya)
            Set S2 = Workbooks(Dosya).Sheets(1)
            For Each Alan In S2.Range("G23:K23")
                If Alan.Value <> "" Then
                    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row + 1
                    S1.Range("B" & Son).Resize(1, 7).Value = Application.Transpose(Alan.Resize(7).Value)
                    S1.Range("I" & Son).Resize(1, 2).Value = Application.Transpose(Alan.Offset(15).Resize(2).Value)
                    S1.Range("K" & Son).Resize(1, 3).Value = Application.Transpose(Alan.Offset(21).Resize(3).Value)
                    S1.Range("A" & Son).Resize(Alan.Rows.Count, 1).Value = S2.Range("B2").Value
                End If
            Next
            Workbooks(Dosya).Close 0
        End If
        Dosya = Dir
    Wend
   
    Set S1 = Nothing
    Set S2 = Nothing
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

tukayf · 1 Aralık 2020

Hocam zihninize sağlık çok teşekkürler.

caytug · 17 Aralık 2020

Sayın korhan, Hedef dosyayı isim belirtmeden dosya aç diyalog penceresinden herhangi bir dosya seçmemiz mümkünmüdür.
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 Yol As String, Kaynak_Dosya As Variant, X As Byte
Dim Hedef_Dosya As String, Son As Long, Sutun As Byte

Zaman = Timer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

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

Yol = ThisWorkbook.Path & Application.PathSeparator
Hedef_Dosya = Yol & "Hedef.xlsm"

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

Kaynak_Dosya = Array("dosya1.xls", "dosya2.xls", "dosya3.xls")

Sutun = 1

For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
Set K2 = XL_App.Workbooks.Open(Yol & Kaynak_Dosya(X))
Set S2 = K2.Sheets("Sheet0")

Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
S2.Range("A1" & 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 = xlCalculationAutomatic
Application.ScreenUpdating = True

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

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 Yol As String, Kaynak_Dosya As Variant, X As Byte
    Dim Hedef_Dosya As Variant, Son As Long, Sutun As Byte
   
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Hedef_Dosya = Application.GetOpenFilename(FileFilter:="Excel Dosyası, *.xls; *.xlsx; *.xlsm", MultiSelect:=False)
   
    If Hedef_Dosya = False Then
        MsgBox "İşleme devam edebilmeniz için dosya 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")
   
    Kaynak_Dosya = Array("dosya1.xls", "dosya2.xls", "dosya3.xls")
   
    Sutun = 1
   
    For X = LBound(Kaynak_Dosya) To UBound(Kaynak_Dosya)
        Set K2 = XL_App.Workbooks.Open(Yol & 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 Korhan,

If Hedef_Dosya = False Then
MsgBox "İşleme devam edebilmeniz için dosya seçmelisiniz!", vbCritical
Exit Sub
End If
Kodun bu kısmını kaldırmadan hedef dosyaya kaydetmiyordu, bu kısmı kaldırdım kaydediyor.bu haliyle işimi gördü, Teşekkür ederim ellerinize sağlık.

Korhan Ayhan · 17 Aralık 2020

Kodun o bölümü dosya seçimi yapmadığınız durumlarda devreye girmesi gerekiyor.

Dosya seçimi yaptığınızda o uyarıyı görmemeniz gerekir.

Ayrıca üstte paylaştığım kod bloğunda iki satırın yerini değiştirdim. Son halini kullanınız.

caytug · 17 Aralık 2020

Sayın Korhan, Uyarıyı görmüyorum işlem yaptı görünüyor ancak hedef dosyaya kaydetmiyor.

Korhan Ayhan · 17 Aralık 2020

Sizin foruma eklediğiniz kod üzerinden düzenleme yapmıştım.

Veri aktarımını yapan satırı aşağıdaki gibi değiştirmişsiniz. Bu sebeple aktarım yapmıyor.

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

Bu yazım hatalı olduğu için sorun oluşmuş. Şimdi aktarım yapmıyor dediğinizde detaylı inceledim ve farkettim.

#15 nolu mesajımı revize ettim. Son halini deneyebilirsiniz.

caytug · 17 Aralık 2020

Düzeldi Sayın koray teşekkür ederim ellerine sağlık

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

caytug

Ekli dosyalar

caytug

Korhan Ayhan

Administrator

Ekli dosyalar

caytug

Korhan Ayhan

Administrator

caytug

Ekli dosyalar

tukayf

Korhan Ayhan

Administrator

tukayf

Kapalı Dosyadan Açık Dosyaya Veri Alma

Korhan Ayhan

Administrator

tukayf

Ekli dosyalar

Korhan Ayhan

Administrator

tukayf

caytug

Korhan Ayhan

Administrator

caytug

Korhan Ayhan

Administrator

caytug

Korhan Ayhan

Administrator

caytug