Kapalı dosyalardan koşullu veri almak

[Korhan Ayhan]

Merhaba,

Bende alternatif bir çalışma hazırladım. Veri sayfalarınıza 10.000 satır veri girerek denedim. Ana dosyanızda 10 satır veri ile yaklaşık 1 saniye gibi bir sürede işlemi tamamlıyor. Ana dosyadaki satır sayısını 1000 adede çıkartarak denediğimde benim bilgisayarımda yaklaşık 10 saniye gibi bir sürede işlemi tamamladı. Ana dosyanızdaki satır sayısı artarsa biraz daha yavaşlama yaşayabilirsiniz.

İncelermisiniz.

 

[talebeyim]

Zihninize sağlık korhan bey, bendede 1000satırda, 12,84sn. falan cıkıyor. ama benim şöyle bir sorunum var benim kod yapisini ekteki örnekteki gibi düzenlemem gerekiyor. bu aşamada denemeliyim, aşağıdaki kodları nasıl revize etmeliyim.

Option Explicit

Sub VERİ_AL()
    Dim Dosya_Yolu As String
    Dim Dosya_Sistemi As Object
    Dim Dosya As Object
    Dim K1 As Workbook, K2 As Object
    Dim Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dosya_Yolu = ThisWorkbook.Path
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Set K1 = ThisWorkbook
    
    K1.Sheets("Sayfa1").Range("B2:B" & Rows.Count).ClearContents
    
    
    For Each Dosya In Dosya_Sistemi.GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> ThisWorkbook.Name Then
            Set K2 = Workbooks.Open(Dosya.Path)
            
            K1.Activate
            
            With K1.Sheets("Sayfa1").Range("C2:C" & K1.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row)
                .Formula = "=SUMIF('[" & Dosya.Name & "]" & K2.Worksheets(1).Name & "'!A:A,A2,'[" & Dosya.Name & "]" & K2.Worksheets(1).Name & "'!B:B)"
                .Select
                 'DoEvents
                 'SendKeys "{F2}", True
                 'SendKeys ("^{ENTER}"), True
                 'DoEvents
                .Value = .Value
                .Copy
                .Offset(0, -1).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd
            End With
        
            K2.Close False
        End If
    Next
    
    Range("C:C").Clear
    Range("A1").Select
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Korhan Ayhan]

Merhaba,

Eklediğiniz resme göre örnek dosyaları revize ettim. İncelermisiniz.

 

[eneskus]

Arkadaşlar başlıkla sorunum yakın anlam taşıması ve forum kirliliği yaratmaması için burada sorayım dedim aşağıdaki kod ile kapalı dosyadan veri almaktayım tabiki filitre ederek.

Ancak dosya açılıyor verileri alıyor ve veri.xlsm dosyasındaki değişiklikleri kaydetmek istiyormusunuz diye soruyor.

Bu uyarıdan nasıl kurtulabilirim acaba.
Teşekkür ederim.

 

[talebeyim]

Teşşekkür.

Korhan bey budur işte, yani tek kelimeyle budur, yani kaç saniyede güncellediğini yazmadı ama herhalde, 40-60 saniye arasında güncelledi, Buda benim için çok iyi. Çok teşekkür ederim yaptığınız çalışma için bu çalışma benim için çok değerliydi, sizin sayenizde bunuda aşmış oldum. Çok sağolun Allah razı olsun.


Benim bu tabloya ileride eklentilerimde olacak, örnek veriyorum.
A sütununda kaç satır veri var sayacak, saydığı değer kadar.
C ile D'yi çarpıp G' yazacak
C ile E'yi çarpıp H'ye yazacak
C ile F'yi çarpıp I'ya yazacak.

Yanlız sizden ricam hani sizin bir anlatım tarzınız varya, bu satırda şöyle yapıyor bu komut şu işe yarıyor gibi, bunun cevabını bana o şekilde yapabilirmisiniz.

bu kalıbı öğrenirsem bu tablo üzerinde yapmam gereken dört işlemler var bunlarıda kendim yaparım.

Bu konuda Emeği Geçen Halit ve Korhan beye çok teşekkür ederim.
Hayırlı günler.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Option Explicit
 
Sub VERİ_AL()
    Dim Dosya_Yolu As String
    Dim Dosya_Sistemi As Object
    Dim Dosya As Object
    Dim K1 As Workbook, K2 As Object
    Dim Zaman As Double
    Dim Son_Satir As Long
    Dim Sutun As Integer
    Dim Adres As String
    Dim Say As Integer
    Dim X As Integer
 
    Zaman = Timer
 
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
 
    Dosya_Yolu = ThisWorkbook.Path
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
    Set K1 = ThisWorkbook
 
    K1.Sheets("Sayfa1").Range("D1:" & Cells(Rows.Count, Columns.Count).Address(0, 0)).Clear
    Sutun = 4
    Son_Satir = K1.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
 
    For Each Dosya In Dosya_Sistemi.GetFolder(Dosya_Yolu).Files
        If Dosya.Name <> ThisWorkbook.Name Then
            Set K2 = Workbooks.Open(Dosya.Path)
            Say = Say + 1
 
            K1.Activate
            Adres = Cells(2, Sutun).Address & ":" & Cells(Son_Satir, Sutun).Address
 
            K1.Sheets("Sayfa1").Cells(1, Sutun) = Dosya.Name
            K1.Sheets("Sayfa1").Cells(1, Sutun).Interior.ColorIndex = 6
 
            With K1.Sheets("Sayfa1").Range(Adres)
                .Formula = "=SUMIF('[" & Dosya.Name & "]" & K2.Worksheets(1).Name & "'!A:A,A2,'[" & Dosya.Name & "]" & K2.Worksheets(1).Name & "'!B:B)"
                .Value = .Value
            End With
 
            With K1.Sheets("Sayfa1").Cells(Son_Satir + 1, Sutun)
                .Formula = "=SUM(" & Adres & ")"
                .Value = .Value
            End With
 
            Sutun = Sutun + 1
            K2.Close False
        End If
    Next
 
    Sutun = 4
 
    For X = (Sutun + Say) To (Sutun + Say * 2 - 1)
        Adres = Cells(2, X).Address & ":" & Cells(Son_Satir, X).Address
 
        With K1.Sheets("Sayfa1").Range(Adres)
            .Formula = "=C2*" & Cells(2, Sutun).Address(0, 0)
            .Value = .Value
        End With
 
        Sutun = Sutun + 1
    Next
 
    Range("A1").Select
    Cells.EntireColumn.AutoFit
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub

 

[Korhan Ayhan]

Uygulanan kodun satır satır açıklaması;

Sub VERİ_AL()
Prosedüre başlıyoruz.

Dim Dosya_Yolu As String
Dim Dosya_Sistemi As Object
Dim Dosya As Object
Dim K1 As Workbook, K2 As Object
Dim Zaman As Double
Dim Son_Satir As Long
Dim Sutun As Integer
Dim Adres As String
Dim Say As Integer
Dim X As Integer
Prosedürde kullanacağımız değişkenleri tanımlıyoruz.

Zaman = Timer
Prosedürün başlangıç zamanını bir değişkene atıyoruz.

Application.ScreenUpdating = False
Ekran hareketlerini pasif yapıyoruz. Makronun daha hızlı çalışması için kullanılmıştır.

Application.Calculation = xlCalculationManual
Hesaplama yöntemini manuele ayarlıyoruz. Bu komutta makronun hızlı çalışması amaçlı kullanılmıştır.

Dosya_Yolu = ThisWorkbook.Path
Dosya yolunu tesbit ediyoruz.

Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
Windowsun dosya sistemini setleme yöntemi ile hafızaya alıyoruz. Klasör altındaki dosyaları döngüye almak için kullanacağız.

Set K1 = ThisWorkbook
Ana isimli kitabımızı K1 isimli kısa değişkene atıyoruz. Bu kısa tanımlalar kod içinde pratik yazım amaçlı kullanılmaktadır.

K1.Sheets("Sayfa1").Range("D1:" & Cells(Rows.Count, Columns.Count).Address(0, 0)).Clear
Ana isimli dosyamızda "D1:Son Sütun" aralığını yeni veri aktarımı için biçimleriyle beraber temizliyoruz.

Sutun = 4
Sutun adlı değişkenin değerini 4 olarak belirliyoruz.

Son_Satir = K1.Sheets("Sayfa1").Cells(Rows.Count, 1).End(3).Row
Ana isimli dosyada A sütunundaki son dolu satırın numarasını tesbit ediyoruz.

For Each Dosya In Dosya_Sistemi.GetFolder(Dosya_Yolu).Files
Ana isimli dosyamızın bulunduğu yoldaki tüm dosyaları döngüye alıyoruz.

If Dosya.Name <> ThisWorkbook.Name Then
Döngüdeki dosya adı ile Ana isimli dosyamızın adının birbirine eşit olup olmadığını sorguluyoruz.

Set K2 = Workbooks.Open(Dosya.Path)
Eğer dosya isimleri eşit değilse ilgili dosyayı açarak K2 isimli kısa değişkene atıyoruz.

Say = Say + 1
Say adlı değişkenimize 1 ekliyoruz. Bu değişkeni ileride son istediğiniz eklemeleri döngüyle pratik yapmak amacıyla kullanacağız.

K1.Activate
İki komut önce klasör altındaki dosyayı açtığımız için Ana isimli dosya ikinci planda kaldı. Ana isimli dosyayı aktif yapıyoruz.

Adres = Cells(2, Sutun).Address & ":" & Cells(Son_Satir, Sutun).Address
İlk veri aktarımının yapılacağı adresi tanımlıyoruz.

K1.Sheets("Sayfa1").Cells(1, Sutun) = Dosya.Name
İlk veri aktarımının yapılacağı sütunun ilk hücresine dosyanın adını yazdırıyoruz.

K1.Sheets("Sayfa1").Cells(1, Sutun).Interior.ColorIndex = 6
Bu hücrenin belirgin olması için sarı renge boyuyoruz.

With K1.Sheets("Sayfa1").Range(Adres)
Verinin aktarılacağı sütunu with bloğuna alıyoruz. With-End With ifadesi arasına yazılan komutlarda her satır için dosya adı ya da sayfa adı belirtmenize gerek yoktur. Size yazım kolaylığı sağlar.

.Formula = "=SUMIF('[" & Dosya.Name & "]" & K2.Worksheets(1).Name & "'!A:A,A2,'[" & Dosya.Name & "]" & K2.Worksheets(1).Name & "'!B:B)"
Bloğa aldığımız hücre aralığına açık olan diğer dosyadan verileri aktarmak için ETOPLA formülünü uyguluyoruz.

.Value = .Value
Uygulanan formülü değere çeviriyoruz.

End With
With bloğunu sonlandırıyoruz.

With K1.Sheets("Sayfa1").Cells(Son_Satir + 1, Sutun)
Yeni bir with bloğu açıyoruz. Bundaki amaç aktarım yapılan sütunun en altındaki boş hücreye ilgili sütunun toplamını aldırmaktır.

.Formula = "=SUM(" & Adres & ")"
Toplama formülünü yazdırıyoruz.

.Value = .Value
Toplama formülünü değere çeviriyoruz.

End With
With bloğunu sonlandırıyoruz.

Sutun = Sutun + 1
Sutun değerine 1 ekliyoruz.

K2.Close False
Açık olan dosyayı kapatıyoruz.

End If
Eğer sorgusunu sonlandırıyoruz.

Next
Döngüye devam ediyoruz. Döngü klasörün içindeki dosya sayısı kadar devam edecektir.

Sutun = 4
Döngü içinde dosya sayısına göre artana Sutun değişkenini tekrar 4 değerine eşitliyoruz. Bundaki amaç son istediğiniz çarpma işlemlerini dinamik hale getirmek içindir.

For X = (Sutun + Say) To (Sutun + Say * 2 - 1)
X adında yeni bir döngüye başlıyoruz. Bu döngüyü çarpma işlemleri için kullanacağız. Döngü dosya işlemlerinin bittiği son boş sütundan açılan dosya sayısının 2 katınının 1 eksiği sütun kadar devam edecektir.

Adres = Cells(2, X).Address & ":" & Cells(Son_Satir, X).Address
Çarpma işleminin yapılacağı ilk adresi belirliyoruz.

With K1.Sheets("Sayfa1").Range(Adres)
Bu adresi with bloğuna aktarıyoruz.

.Formula = "=C2*" & Cells(2, Sutun).Address(0, 0)
Çarpma işleminin formülü yazdırıyoruz.

.Value = .Value
Formülü değere çeviriyoruz.

End With
With bloğunu sonlandırıyoruz.

Sutun = Sutun + 1
Sutun değerine 1 ekliyoruz.

Next
X adlı döngümüze devam ediyoruz.

Range("A1").Select
İşlemler bittiği için A1 hücresini seçtiriyoruz. İsteğe bağlıdır. Kullanmayabilirsiniz.

Cells.EntireColumn.AutoFit
İşlem sonunda tüm sütunların genişliğini otomatik ayarlıyoruz.

Application.Calculation = xlCalculationAutomatic
Hesaplama özelliğini otomatik olarak ayarlıyoruz.

Application.ScreenUpdating = True
Ekran hareketlerini tekrar aktif hale getiriyoruz.

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
Kullanıcıya işlemin tamamlandığını ve işlem süresini bildiriyoruz.

End Sub
Prosedürü sonlandırıyoruz.

 

[talebeyim]

Çok çok teşekkür ederim Korhan bey, sağolun. tam istediğim gibi olmuş.

 

[talebeyim]

Yeni bir eklenti.

Korhan bey satırı arttırdıkça malum sürede uzuyor, Ben bir örnek gördüm, ekteki progress bar örneğini bu rapora nasıl ekleyebilirim ?

 

[talebeyim]

günceldir.

 

[talebeyim]

Arkadaşlar ProgressBar ile ilgili yardımcı olabilecek kimse varmı ?

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı inceleyiniz.

 

[talebeyim]

hata .

Teşekkür ederim Korhan bey,
Ekteki gibi bir uyarı ve/veya hata ile karşılaştım. Sorunu nasıl aşabilirim?

Birde progressbarı kodlar üzerinden kısa anlatmanız mümkünmü ?

 

[talebeyim]

Olmuyor korhan bey, araştırıp hata kodundaki gerekli ocx.leri indirip kaydettim, registery etmem rağmen maalesef hala calısmıyor

 

[Korhan Ayhan]

Merhaba,

Ben 2003 versiyonda ilgili nesneyi ekledim. Siz 2007 versiyon kullanıyorsunuz. Form üzerindeki nesneyi silip kendi versiyonunuzdaki nesneyi eklemeyi deneyin.

 

[talebeyim]

kendi versiyonumla ilgili nesneyi nereden bulabilirim?
hangisi olduğunu bilmiyorum anlamında sordum.

 

[talebeyim]

Koray bey cok teşekkür ederim, 36 cevaba ulaşmış bu konu. Ado ile veri alma konusu sizin açıklayıcı cevaplarınızla daha kolay anlaşılıyor ve geliştirebiliyorum.

Progressbar ile ilgi çalışmanız içinde teşekkür ederim, Siz yaptınız ama ben uzerinde denemeler yapıyorum fakat bir türlü progressbar ile kod bloğunu birleştiremedim. Hz. googleden baya bi döküman makele falan okuyacağız anlaşılan.

En son dosyanızda nesne eklemiyle birlikte çok sade ve sorunsuz çalışıyor. Bu hazırladığınız tablo hakkında cok eklenti yapmalıyım ama onların herbirini yeni başlıkla açayım.

Konu çözülmüştür. Ben konuyu kapatıyorum.

 

[Korhan Ayhan]

Merhaba,

Sanıyorum 2007 ve sonraki versiyonlarda "Progressbar" nesnesi kaldırılmış. Bende "Label" nesnesi kullanarak alternatif bir çözüm hazırladım. Ekteki dosyayı inceleyiniz.

Not: Siz başlığınızda ADO ile çözüm istemiştiniz. Benim verdiğim çözümde ADO kullanılmamıştır. Konuyu inceleyen diğer üyelerimizi yanlış yönlendirmemiş olalım.

 

[talebeyim]

Korhan bey haklısınız, konu başlığını değiştirip dış veri alma olarak yazabilirmisiniz, ayrıca microsoft ProgressBar 6.0 diye bir nesne var, ben ilk gönderdiğinizi uzun uğraş sonunda çalıştırdım. Ama sizden bir ricam var lütfen, 6 kadar metin okudum bu progressbarlarla ilgili lütfen en basit şekilde siz bir anlatırmısınız ? Anlatım tarzınız çok hoş.
Yani diyelimki bir progresbar koyduk, min ve max valueleri tanımladık. Tamamda.
Örnek veriyorum bir düşeyara ve/veya Toplama işlemi falan yaptık. bu ilişkiyi Progress nesnesi ile nasıl ilişkilendiriyoruz. Kafam hiç almadı ?

 

[Korhan Ayhan]

Merhaba,

Progressbar nesnesinin kullanımı ile ilgili aşağıdaki örnek kodlama sanırım size fikir verecektir.

Amaç;

A sütununda A1:A10000 hücrelerine www.excel.web.tr ifadesini yazdırmak.
Bu işlem esnasında işlemin uzun süreceğini düşünerek form üzerinde Progressbar nesnesi ile kullanıcıyı işlemin hangi aşamada olduğu görsel olarak göstermek istiyoruz.

Kullanılan kod;

Private Sub UserForm_Activate()
    Dim X As Integer
 
    With Me.ProgressBar1
        .Min = 0
        .Max = 10000
    End With
 
    For X = 1 To 10000
        Cells(X, 1) = "www.excel.web.tr"
        Me.ProgressBar1.Value = X
        Me.Repaint
    Next
 
    Unload Me
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Kodun açıklaması;

Görsel olarak formun üzerinde görünmesini istediğimiz işlemler için formun aktif olma olayı (Activate) kullanılır.

Private Sub UserForm_Activate()
Formun aktiv olma olatına başlıyoruz.

Dim X As Integer
Prosedürde kullanacağımız değişkeni tanımlıyoruz.

With Me.ProgressBar1
Progressbar nesnesinin özelliklerini belirlemek için With bloğunu açıyoruz.

.Min = 0
Nesnenin minimum değerini sıfır olarak tanımlıyoruz.

.Max = 10000
Nesnenin maksimum değerini onbin olarak tanımlıyoruz.

End With
With bloğunu kapatıyoruz.

For X = 1 To 10000
Hücrelere değer atamak için X adındaki döngümüze başlıyoruz. Progressbar nesnesinin maksimum değeri ile döngümüzün bitiş değeri aynıdır. Bu işlemin püf noktası burasıdır. Yani Progressbar nesnesinin işlem ile aynı sürede tamamlanması için makromuzun bitiş değerini mutlaka bilmemiz gerekiyor. Bilmiyorsak aynı anda çalışan nesneyi elde etmeniz mümkün değildir.

Cells(X, 1) = "www.excel.web.tr"
A sütunundaki ilgili hücreye değerimizi yazdırıyoruz.

Me.ProgressBar1.Value = X
Nesnemizin değerinide döngü değeri olarak belirliyoruz. Eğer değerler birbirine eşit olmasaydı bu durumda değerleri birbirine bölerek bir oran bulup nesneye bu oran kadar değer atamamız gerekecekti.

Me.Repaint
Form üzerindeki görsel işlemlerin daha sağlıklı görünmesi için kullanılan bir komuttur.

Next
Döngümüze devam ediyoruz.

Unload Me
İşlem bittiği için açık olan formu kapatıyoruz.

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
İşlemin bittiğine dair kullanıcıya bilgilendirme mesajı veriyoruz.

End Sub
Prosedürü sonlandırıyoruz.


Aşağıdaki kodda Progressbar nesnesinin maksimum değeri ile döngümüzün bitiş değeri aynı değildir. Bu gibi durumlarda aşağıdaki yapıyı kullanabilirsiniz.

Private Sub UserForm_Activate()
    Dim X As Integer
 
    With Me.ProgressBar1
        .Min = 0
        .Max = 100
    End With
 
    For X = 1 To 10000
        Cells(X, 1) = "www.excel.web.tr"
        Me.ProgressBar1.Value = X / 100
        Me.Repaint
    Next
 
    Unload Me
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Değerlerle oynayarak nesnenin nasıl tepki verdiğini gözlemleyebilirsiniz.