Soru Kapalı kitaplardan VERİ ÇEKMEK

Korhan Ayhan · 16 Aralık 2019

Alternatif;

Hız olarak avantaj sağlayabilir.

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String
    Dim Dosya As String, Son As Long, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    
    Yol = K1.Path & Application.PathSeparator
    
    S1.Range("A2:AH" & S1.Rows.Count).ClearContents
    Son = 2
    
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If Dosya <> K1.Name Then
            S1.Cells(Son, 1) = Dosya
            
            With Range("B" & Son & ":L" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$E:$E,MATCH(B$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$D:$D,0))"
                .Value = .Value
            End With
            
            With Range("M" & Son & ":W" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$H:$H,MATCH(M$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$F:$F,0))"
                .Value = .Value
            End With
            
            With Range("X" & Son & ":AH" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$I:$I,MATCH(X$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$J:$J,0))"
                .Value = .Value
            End With
            
            Son = Son + 1
        End If
                
        Dosya = Dir
    Wend
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    If Son - 1 > 1 Then
        MsgBox "Veri aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Klasörde veri aktarımı yapılacak dosya bulunamadı!", vbExclamation
    End If
End Sub

ERMAN SAYINALP · 16 Aralık 2019

Korhan Ayhan' Alıntı:

Alternatif;

Hız olarak avantaj sağlayabilir.

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String
    Dim Dosya As String, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
   
    Yol = K1.Path & Application.PathSeparator
   
    S1.Range("A2:AH" & S1.Rows.Count).ClearContents
    Son = 2
   
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If Dosya <> K1.Name Then
            S1.Cells(Son, 1) = Dosya
           
            With Range("B" & Son & ":L" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$E:$E,MATCH(B$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$D:$D,0))"
                .Value = .Value
            End With
           
            With Range("M" & Son & ":W" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$H:$H,MATCH(M$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$F:$F,0))"
                .Value = .Value
            End With
           
            With Range("X" & Son & ":AH" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$I:$I,MATCH(X$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$J:$J,0))"
                .Value = .Value
            End With
           
            Son = Son + 1
        End If
               
        Dosya = Dir
    Wend
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    If Son - 1 > 1 Then
        MsgBox "Veri aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Klasörde veri aktarımı yapılacak dosya bulunamadı!", vbExclamation
    End If
End Sub

Harikanın fevkinde, muhteşem, çok teşekkür ediyorum...

ERMAN SAYINALP · 16 Aralık 2019

Korhan beycim merhaba,

Sizden değerli yardımlarınızı bir kez daha istirham ediyorum. Şöyle ki;

Bir Kitabın (Kaynak) (ör: Sayfa1) Sayfasından, bir başka Kitabın (Hedef) (ör:Sayfa1) Sayfasına Verileri taşımak istiyorum.

Koşullar;

Kaynak Sayfadan KOPYALA, Hedef Sayfaya YAPIŞTIR-DEĞERLER mantığıyla olmalı,
Makro Yeri HEDEF Dosyada olmalı,
Makro Tetiklendiğinde, KAYNAK Dosya Konumunu sormalı,
Yol gösterildiğinde, işlem sonuçlandırılmalı,

Taşınacak Veri Hücreleri;

Kaynak C2 --- Hedef C2
Kaynak D2 --- Hedef D2
Kaynak F2 --- Hedef F2
Kaynak C16 --- Hedef C18
Kaynak F16 : G16 --- Hedef F18 : G18
Kaynak C17 : G10000 --- Hedef C19 : G10000
Kaynak I16 : I10000 --- Hedef I18 : I10000

Konuya ilişkin bir MAKRO yazabilirseniz çok memnun olurum.

Görüşmek dileğiyle...

ERMAN SAYINALP · 16 Aralık 2019

Korhan Ayhan' Alıntı:

Alternatif;

Hız olarak avantaj sağlayabilir.

Kod:

Option Explicit

Sub Verileri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String
    Dim Dosya As String, Son As Long, Zaman As Double
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
   
    Yol = K1.Path & Application.PathSeparator
   
    S1.Range("A2:AH" & S1.Rows.Count).ClearContents
    Son = 2
   
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If Dosya <> K1.Name Then
            S1.Cells(Son, 1) = Dosya
           
            With Range("B" & Son & ":L" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$E:$E,MATCH(B$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$D:$D,0))"
                .Value = .Value
            End With
           
            With Range("M" & Son & ":W" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$H:$H,MATCH(M$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$F:$F,0))"
                .Value = .Value
            End With
           
            With Range("X" & Son & ":AH" & Son)
                .Formula = "=INDEX('" & Yol & "[" & Dosya & "]Sayfa1'!$I:$I,MATCH(X$1," & "'" & Yol & "[" & Dosya & "]Sayfa1'!$J:$J,0))"
                .Value = .Value
            End With
           
            Son = Son + 1
        End If
               
        Dosya = Dir
    Wend
   
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    If Son - 1 > 1 Then
        MsgBox "Veri aktarım işlemi tamamlanmıştır." & Chr(10) & Chr(10) & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Klasörde veri aktarımı yapılacak dosya bulunamadı!", vbExclamation
    End If
End Sub

Korhan bey, tekrar merhaba

"Kapalı Kitaplardan Veri Çekmek" konulu soruma karşın yukarıda yazdığınız kodlamayı, çalışmamın orjinaline uyguladığımda #YOK sonuçlarıyla karşılaştım. Yazılımın içeriğini bilemediğim için 10'larca test yaparak arızayı buldum. Şöyle ki;

Örnek Dosyalarda VERİ1, VERİ2 VERİ3 .... VERİ33 biçiminde yazdığım Veri Başlıkları, Orjinalinde Satışlar, İadeler, Tahsilatlar, Çekler, Senetler vs.vs gibi.
Bu yüzden sistem Veri Başlıklarını okuyamadığından, Veri çekilecek hücrelere #YOK hatası verdiriyor.

Yukarıdaki Kodlamayı, Veri Başlıklarının "Değişken kelimelerden" olduğunu belirtir şekilde Revize edebilir misiniz. ?

Vaki zahmetleriniz için şimdiden teşekkür ederim.

Saygılarımla.

ERMAN SAYINALP · 16 Aralık 2019

ERMAN SAYINALP' Alıntı:
Korhan bey, tekrar merhaba

"Kapalı Kitaplardan Veri Çekmek" konulu soruma karşın yukarıda yazdığınız kodlamayı, çalışmamın orjinaline uyguladığımda #YOK sonuçlarıyla karşılaştım. Yazılımın içeriğini bilemediğim için 10'larca test yaparak arızayı buldum. Şöyle ki;

Örnek Dosyalarda VERİ1, VERİ2 VERİ3 .... VERİ33 biçiminde yazdığım Veri Başlıkları, Orjinalinde Satışlar, İadeler, Tahsilatlar, Çekler, Senetler vs.vs gibi.
Bu yüzden sistem Veri Başlıklarını okuyamadığından, Veri çekilecek hücrelere #YOK hatası verdiriyor.

Yukarıdaki Kodlamayı, Veri Başlıklarının "Değişken kelimelerden" olduğunu belirtir şekilde Revize edebilir misiniz. ?

Vaki zahmetleriniz için şimdiden teşekkür ederim.

Saygılarımla.

Örnek Dosyaların (A Firması, B Firması, C Firması vs) Orjinal Görüntüsü ekteki gibidir.

Ancak Hücre Adresleri birebir aynıdır.

Korhan Ayhan · 17 Aralık 2019

Erman Bey,

Kod arama yöntemi ile sonuç veriyor. Bu sebeple aranan verilerin aynı olması gerekiyor ki sonuç versin. Eğer verilerin sonunda ya da başında boşluk karakteri varsa eşleşme olmayacağı için sonuç olarak YOK hatası verecektir. Bu duruma dikkat ediniz.

ERMAN SAYINALP · 17 Aralık 2019

Korhan Ayhan' Alıntı:
Erman Bey,

Kod arama yöntemi ile sonuç veriyor. Bu sebeple aranan verilerin aynı olması gerekiyor ki sonuç versin. Eğer verilerin sonunda ya da başında boşluk karakteri varsa eşleşme olmayacağı için sonuç olarak YOK hatası verecektir. Bu duruma dikkat ediniz.

Korhan bey,

Bu konu tamamdır, yardım istediğim diğer konu ile ilgili desteğiniz olabilir mi acaba ?

Soru Kapalı kitaplardan VERİ ÇEKMEK

Korhan Ayhan

Administrator

ERMAN SAYINALP

ERMAN SAYINALP

ERMAN SAYINALP

ERMAN SAYINALP

Korhan Ayhan

Administrator

ERMAN SAYINALP