Çözüldü Kapalı Sayfalardan Belirtilen Koşulla Göre Veri Aktarmak.

[gicimi]

Workbooks(dosya3).Close satırın altına
On Error Resume Next deyim satırını ekleyip deneyin.

@Ziynettin Report sayfasında sadece 48. satıra kadar ki bilgileri getiriyor. Kod diğer satırlara ait bilgileri getirmiyor.

 

[Haluk]

Bilemiyorum, bende bir sıkıntı olmadı.

Sorun belki kullanılan driver'ın sizin 64 bit'i desteklememesi olabilir. Dosyayı diğer dosyaların olduğu klasöre yerleştirip de açtınız değil mi?

.

 

[gicimi]

Evet. Aynı klasör içerisinde çalıştırdım.

 

[Ziynettin]

@Ziynettin Report sayfasında sadece 48. satıra kadar ki bilgileri getiriyor. Kod diğer satırlara ait bilgileri getirmiyor.

Report sayfası D10 hücresindeki aranan değeri D60 hücresine yazarak kodu öyle deneyin. 60. satıra bilgiler geliyor mu.

 

[gicimi]

@Ziynettin Bey Merhaba;

Reportun A-B-C Sütunları boş olduğu zaman hata veriyor şimdi çözdüm. G sütunundaki saat formatını (ss:dd:nn) düzeltebilir miyiz. "

 

[Ziynettin]

F sütunu tarih, G sütunu saat biçimi olarak düzenlendi.
Ne kadar sürede işleminiz gerçekleşiyor.

Sub bul()
Application.ScreenUpdating = False
Z = TimeValue(Now)
yol = "C:\Veri"
dosya1 = "Data.xlsx"
dosya2 = "ADM.xlsx"
dosya3 = "SDM.xlsx"

GetObject (yol & "\" & dosya1) 'Data
Set s1 = Workbooks(dosya1).Sheets("Sayfa1")
a = s1.Range("C2:O" & s1.Cells(Rows.Count, 3).End(3).Row).Value
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(a): d(a(i, 1)) = i: Next i

GetObject (yol & "\" & dosya2) 'AMD
Set s1 = Workbooks(dosya2).Sheets("Sayfa1")
a1 = s1.Range("D2:H" & s1.Cells(Rows.Count, 4).End(3).Row).Value
Set d1 = CreateObject("scripting.dictionary")
For i = 1 To UBound(a1): d1(a1(i, 1)) = a1(i, 5): Next i

GetObject (yol & "\" & dosya3) 'SMD
Set s1 = Workbooks(dosya3).Sheets("Sayfa1")
a2 = s1.Range("D2:H" & s1.Cells(Rows.Count, 4).End(3).Row).Value
Set d2 = CreateObject("scripting.dictionary")
For i = 1 To UBound(a2): d2(a2(i, 1)) = a2(i, 5): Next i


Workbooks(dosya1).Close
Workbooks(dosya2).Close
Workbooks(dosya3).Close

On Error Resume Next
Set sh = Sheets("Sayfa1")
b = sh.Range("D2:D" & sh.Cells(Rows.Count, 3).End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 8)
For i = 1 To UBound(b)
    For j = 1 To 7
        c(i, j) = a(d(b(i, 1)), j + 6)
    Next j
    c(i, 8) = d1(b(i, 1))
    If c(i, 8) = "" Then
        c(i, 8) = d2(b(i, 1))
    End If
Next i

sh.[E2].Resize(UBound(b), 8) = c
sh.[F2].Resize(UBound(b)).NumberFormat = "dd.mm.yyyy"
sh.[G2].Resize(UBound(b)).NumberFormat = "hh:mm:ss"
Application.ScreenUpdating = True

MsgBox "İşlem tamam." & vbLf & vbLf & CDate(TimeValue(Now) - Z), vbInformation
End Sub

 

[gicimi]

@Ziynettin Bey 2-4 dk arası sonuç elde edebiliyorum.

 

[Zeki Gürsoy]

Ekli dosyayı klasörün içine attıktan sonra çalıştırıp test edebilirsiniz.
(64 bit Excel ile daha performanslı çalışmakta)

 

[gicimi]

@Zeki Gürsoy Merhaba;
Aynı Dosyaların içerisine yüklediğiniz dosyayı indirdim ve çalıştırdım. Resimlerdeki hata ile karşılaştım.

 

[Zeki Gürsoy]

Sayfa1 isimli çalışma sayfasını bulamadığını söylüyor. İsimleri her dört dosyanın adını Sayfa1 olarak ayarlayın. Çalıştırmadan önce de o dört dosya kapalı olmasına dikkat edin.

 

[gicimi]

Zeki Bey Tüm sayfaların ismi "Sayfa1" ve hepsi kapalıyken çalıştırdım. Aynı hata ile karşılaşıyorum. Göndermiş olduğunuz dosyanın adını da Report ismini verdim. Aynı hatayı verdi.

 

[gicimi]

@Ziynettin Bey emeğinizi sağlık. Bunu da alternatif olarak kullanacağım. Kolaylıklar.

 

[Haluk]

Zeki Bey, elinize sağlık ....

32 Bit Office 2010 ile, örnek dosyalarda işlem 6,48 saniyede tamamlandı.

Selamlar,
.

 

[Zeki Gürsoy]

Teşekkürler Haluk Bey.
Gördüğünüz süre aslında örnek dosyalardaki 40-50 satırlık verilerin işlenme süresi değil. Dosyalarda CTRL + End yapıldığında çalışma alanının çok daha büyük olduğunu görebilirsiniz. Yani gerçekte işlenen kayıt sayıları (null değerler dahil) aşağıdaki gibidir:
Report.xlsx : 100.000
Data.xlsx : 100.000
ADM.xlsx : 100.000
SDM.xlsx : 100.000

 

[Haluk]

Farkındayım Zeki Bey;

Ben de konuyla ilgili epey kafa yormuştum. Dosyalardaki "null" değerleri o zaman fark ettim ben de.

Kısıtlı SQL bilgim ve sorudan anladığım kadarıyla 35. mesajda bir şeyler yapmaya çalışmıştım. Soruyu soran arkadaş o dosyada da hata almıştı.

.

 

[Erdem Akdemir]

Zeki Bey, elinize sağlık ....

32 Bit Office 2010 ile, örnek dosyalarda işlem 6,48 saniyede tamamlandı.

Selamlar,
.

Haluk bey merhaba,

Zeki bey'in kodlarının çalıştığı örnek excelleri yükleyebilir misiniz.
İlk mesajdaki örnekler kaybolmuş.

 

[Haluk]

Haluk bey merhaba,

Zeki bey'in kodlarının çalıştığı örnek excelleri yükleyebilir misiniz.
İlk mesajdaki örnekler kaybolmuş.

Kodların olduğu dosya 48. mesajda.

.

 

[Erdem Akdemir]

Kodların olduğu dosya 48. mesajda.

.

Zeki bey'in bağlandığı örnek excel dosyalarını istemiştim.
Gicimi'nin yüklediği örnek dosyalar yandex'ten silinmiş.

 

[Zeki Gürsoy]

#22 nolu mesajda var.
Örnek dosyalar : https://yadi.sk/d/uR96QwKKgVtWiQ

 

[Haluk]

Zeki bey'in bağlandığı örnek excel dosyalarını istemiştim.
Gicimi'nin yüklediği örnek dosyalar yandex'ten silinmiş.

Dosyalar aşağıdaki linktedir...

https://drive.google.com/open?id=1IWks3YALo5depl6LU8wAzEmdHuoftq1j

.