• DİKKAT

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

Soru Kapalı kitaplardan VERİ ÇEKMEK

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


Harikanın fevkinde, muhteşem, çok teşekkür ediyorum...
 
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...
 
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
Genişletmek için tıkla ...



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

Ö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.Resim.JPG
 
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 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.
Genişletmek için tıkla ...


Korhan bey,

Bu konu tamamdır, yardım istediğim diğer konu ile ilgili desteğiniz olabilir mi acaba ?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst