Birden Çok Kapalı Dosyadan Veri Alma

[TheGreatest]

Birden Çok Kapalı Dosyadan Veri Alma - cevaplandı

Merhaba arkadaşlar.

Ekteki örnek dosyada her ay işyerindeki departmanlarca yapılması gereken birkaç işlemin kontrolünü takip için hazırladığım dosya var.

ANA_Dosya.xls (benim kendi dosyam)

Departmanlar klasöründe ise departmanlara gönderdiğim dosyalar var. Bu dosyalar geri geldiğinde, her dosyanın 'cevap' sütunundaki verileri ANA_Dosya.xls'in 'cevap' sütununda ilgili alana yapıştıracak bir VBA koduna ihtiyacım var.

İlgilenen arkadaşlara şimdiden cok teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Ekteki dosyayı incelermisiniz.

Uygulanan kod;

Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim İlk_Süre As Date, Son_Süre As Date, Toplam_Süre As Date
    Dim Veri_Dosyası As Workbook, Dosya As String, Kaynak_Dosya As Workbook, Dosya_Yolu As String
    Dim Hücre1 As Range, Hücre2 As Range, Satır As Long, Bul As Range
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    İlk_Süre = Time
    
    Set Veri_Dosyası = ThisWorkbook
    
    Veri_Dosyası.Sheets("Main").Range("C2:C65536").ClearContents
    
    Dosya_Yolu = Veri_Dosyası.Path & "\Departmanlar\"
    
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
    
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    
        For Each Hücre1 In Veri_Dosyası.Sheets("Main").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
        
        Satır = Cells(Hücre1.Row, 2).End(4).Row
        
            Dosya = Dir(Dosya_Yolu & Hücre1.Value & ".xls")
            
            If Dosya <> "" Then
            
            Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & Hücre1.Value & ".xls", False, False)
        
                For Each Hücre2 In Veri_Dosyası.Sheets("Main").Range("B" & Hücre1.Row, "B" & Satır)
                
                    Set Bul = [B:B].Find(Hücre2.Value, LookAt:=xlWhole)
                    
                    If Not Bul Is Nothing Then
                    
                    Veri_Dosyası.Sheets("Main").Cells(Hücre2.Row, 3) = Cells(Bul.Row, 3)
                    
                    End If
            
                Next
            
            Kaynak_Dosya.Close True
        
        End If
        
        Next
    
    End If
    
    Son_Süre = Time
    
    Toplam_Süre = Format(Son_Süre - İlk_Süre, "hh:mm:ss")
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi ; " & Toplam_Süre, vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

 

[scream_42]

Soru

Çok özür dileyerek birşey sormak istiyorum. Bunun için böyle uzun uzaya koda ihtiyaç var mı?

Ana dosyadaki ilgili sorunun cevabının geleceği satıra = ile gidip cevaptaki yeri yazmak ile soun çözülmüyor mu? Ana dosyayı açarken güncelle deyince verileri alıyor.
Eksik bilgim varsa öğreneyim ben de.

 

[Korhan Ayhan]

Selamlar,

Sn. scream 42,

Soruyu soran arkadaşımız cevabı bu şekilde istediği için yanıtımızda bu yönde oldu.

Departmanlar klasöründe ise departmanlara gönderdiğim dosyalar var. Bu dosyalar geri geldiğinde, her dosyanın 'cevap' sütunundaki verileri ANA_Dosya.xls'in 'cevap' sütununda ilgili alana yapıştıracak bir VBA koduna ihtiyacım var.

Tabiki belirttiğiniz şekildede verileri almak mümkün.

 

[scream_42]

Teşekkürler efendim aydınlatmanız için

 

[TheGreatest]

Sayın Korhan,

Çok teşekkür ederim, tam istediğim gibi olmuş.

Saygılar.

 

[TheGreatest]

Sayin Korhan'in kodlari sayesinde, her sayfanin C sutunundaki bilgileri ana dosyamiza kopyaliyoruz, eger C sutunuyla birlikte D sutununu da kopyalamak istersek, kodlari nasil duzenleyebiliriz?

Saygilar.

 

[wishm]

Uygulamayı çalıştıramadım. Dosya bulunamamıştır uyarısı alıyorum. Yardımcı olursanız sevinirim. Saygılarımla...

 

[TheGreatest]

Sayin Korhan'in kodlari sayesinde, her sayfanin C sutunundaki bilgileri ana dosyamiza kopyaliyoruz, eger C sutunuyla birlikte D sutununu da kopyalamak istersek, kodlari nasil duzenleyebiliriz?

Saygilar.

Arkadaslar, bu soruna bir cozum bulabilecekmiyiz

 

[Korhan Ayhan]

Selamlar,

Önerdiğim kodu aşağıdaki şekilde revize ederseniz C-D sütunlarını beraber aktarabilirsiniz.

Option Explicit
 
Sub TÜM_VERİLERİ_AL()
    Dim İlk_Süre As Date, Son_Süre As Date, Toplam_Süre As Date
    Dim Veri_Dosyası As Workbook, Dosya As String, Kaynak_Dosya As Workbook, Dosya_Yolu As String
    Dim Hücre1 As Range, Hücre2 As Range, Satır As Long, Bul As Range
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    İlk_Süre = Time
    
    Set Veri_Dosyası = ThisWorkbook
    
    Veri_Dosyası.Sheets("Main").Range("C2:[COLOR=red]D[/COLOR]65536").ClearContents
    
    Dosya_Yolu = Veri_Dosyası.Path & "\Departmanlar\"
    
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
    
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    
        For Each Hücre1 In Veri_Dosyası.Sheets("Main").Columns("A:A").SpecialCells(xlCellTypeConstants, 23)
        
        Satır = Cells(Hücre1.Row, 2).End(4).Row
        
            Dosya = Dir(Dosya_Yolu & Hücre1.Value & ".xls")
            
            If Dosya <> "" Then
            
            Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & Hücre1.Value & ".xls", False, False)
        
                For Each Hücre2 In Veri_Dosyası.Sheets("Main").Range("B" & Hücre1.Row, "B" & Satır)
                
                    Set Bul = [B:B].Find(Hücre2.Value, LookAt:=xlWhole)
                    
                    If Not Bul Is Nothing Then
                    
                    Veri_Dosyası.Sheets("Main").Cells(Hücre2.Row, 3) = Cells(Bul.Row, 3)
                    [COLOR=red]Veri_Dosyası.Sheets("Main").Cells(Hücre2.Row, 4) = Cells(Bul.Row, 4)[/COLOR]
                    
                    End If
            
                Next
            
            Kaynak_Dosya.Close True
        
        End If
        
        Next
    
    End If
    
    Son_Süre = Time
    
    Toplam_Süre = Format(Son_Süre - İlk_Süre, "hh:mm:ss")
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & "İşlem süresi ; " & Toplam_Süre, vbInformation
    Exit Sub
Son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

 

[TheGreatest]

Sn. Korhan,

Teşekkür ederim.