kapalı çalışma kitaplarının, farklı sheetlerinden veri çekmek

[moebius06]

Selamlar

farklı klasörler içinde bulunan ( firmalar) farklı çalışma kitaplarından ( parça isimleri) ve her çalışma kitabının içindeki farklı sheetlerden ( aylar ) 2 ayrı veriyi çekerek " liste" çalışma kitabına nasıl yazdırabiliriz??( makro yada kod ile )

" liste" çalışma kitabı açıldığında, kapalı çalışma kitaplarından veri çekerek güncellenebilmeli

forumdaki bulduğum örnekler ya sadece iki çalışma kitabı arasında yada aynı çalışma kitabının içindeki farklı sheetler arasında... burada yaklaşık 15 firmadan, 350 çalışma kitabının 12 aylık sheetleri olduğu için yaklaşık 350 x12 x2 = 8400 veri çekilmesi gerekiyor 15 firma adına göre....

hücreye (= )ile dosya yolu/ dosya adı/ sheet göstererek gitmek zor oluyor ve ayrıca dosya açılmadan güncelleme yapmıyor...son kaydedildiği haliyle kalıyor

örnek dosyalarım ekte

saygılar

 

[halit3]

Merhaba

Bu kodu sayfanın kod bölümüne kopyala ve makroyu çalıştır açılan liste kutusundan dosyaların bulunduğu klasörü seç ikinci satırda makronun çalıştırdığı kodlar ile ilgili uygulama var verileri 4 satırdan sonra alt alta getiriyor.

Dim Klasor As Object
Dim Obj As Object
Dim Kaynak As String

Dim sat As String
Dim Sayfa_Adı As String
Dim tarih As String

Sub veri_al()


b = MsgBox("Sayfayı temizlemek istiyormusunuz.?", vbYesNo) 'Mesaj.İsteğe bağlı yazılmayabilir.
If b = vbYes Then
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).ClearContents
Rows("3:" & Rows.Count).Interior.ColorIndex = xlNone
End If

Sayfa_Adı = ActiveSheet.Name

sat = 2 'Cells(Columns.Count,"A").End(3).Row + 1

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
'Kaynak = Klasor.Items.Item.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
'On Error Resume Next

tarih = Cells(2, 1)

deger1 = Cells(2, 1)
deger2 = Cells(2, 2)
deger3 = Cells(2, 3)
deger4 = Cells(2, 4)
deger5 = Cells(2, 5)


Cells(3, 1) = "Dosya adı"
Cells(3, 2) = "Ay"
'Cells(3, 3) = "Toplam"
Cells(3, 3) = "Tutar"
Cells(3, 4) = "Tutar"



Liste9 (Klasor.Items.Item.Path)


Cells(2, 1) = deger1
Cells(2, 2) = deger2
Cells(2, 3) = deger3
Cells(2, 4) = deger4
Cells(2, 5) = deger5

MsgBox "işlem tamam"

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
    
Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
Hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number

End Sub
 
Private Sub Liste9(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fs = CreateObject("Scripting.FileSystemObject")

ReDim yer(100)


aranan_Uzanti = fs.GetExtensionName(Application.AddIns.Item(1).FullName)

For Each Dosya In fs.GetFolder(yol).Files

If ThisWorkbook.Name = Dosya.Name Then
GoTo Atla2
End If

If "~$" = Mid(Dosya.Name, 1, 2) Then
GoTo Atla2
End If


Uzanti = fs.GetExtensionName(Dosya.Name)
If aranan_Uzanti = "xlam" Then
If Uzanti = "xls" Or Uzanti = "xlsm" Or Uzanti = "xlsx" Or Uzanti = "xlsb" Then
Else
GoTo Atla1
End If
End If

If aranan_Uzanti = "xla" Then
If Uzanti <> "xls" Then
GoTo Atla1
Else
End If
End If





If ThisWorkbook.Name <> Dosya.Name Then
For kak = 1 To 100
yer(kak) = ""
Next


say1 = 0
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
'dosya_adı = dosya
'Data.Open "Driver={Microsoft Excel Driver (*.xls)};Dbq=" & dosya & ";"
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya & ";"
Katalog.ActiveConnection = Data

For Each Tablo In Katalog.Tables

If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")


If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then

son1 = Left$(son1, Len(son1) - 1)

deg = Split(son1, "#")
son = UBound(deg)

If son = 0 Then
Else
say1 = say1 + 1
yer(say1) = Replace(son1, "#", ".")
End If

say1 = say1 + 1
yer(say1) = son1
End If
End If


End If
End If
End If
Next
Data.Close
Set Data = Nothing
Set Katalog = Nothing

Kalasor2 = fs.GetParentFolderName(Dosya)

If Right(Kalasor2, 1) <> "\" Then Kalasor2 = Kalasor2 & "\"
Cells(2, 2).Value = fs.GetFileName(Dosya)


For mat = 1 To say1

SayfaAdi = yer(mat)
Cells(2, 3).Value = SayfaAdi

deg2 = Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi
deg3 = "'" & Kalasor2 & "[" & Dosya.Name & "]" & SayfaAdi & "'!R"

sonsat = Rows.Count - 1
veri_alinacak_bas_sat = 3  'veri alınacak başlangıç satır numarası
veri_alinacak_bas_sut = 1   'veri alınacak başlangıç sütun numarası
bas_satun_no = 3 '         yazmaya başlıyacak ilk sütun

son1 = 0
son2 = 0

'---------------------------------------------------------------------------------------

kap_dos_sütün_no = Split(Cells(2, 1).Address, "$")(1)
kap_dos_satir_no = Cells(2, 1).Row

yer1 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg2 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(2, 4).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
'Cells(2, 4).Value = Cells(2, 4).Value
son1 = Cells(2, 4).Value ' Kapalı dosyaya ait son dolu sütun sayısı

yer2 = "LOOKUP(2,1/('" & deg2 & "'!" & kap_dos_sütün_no & "1:" & kap_dos_sütün_no & sonsat & "<>""""),ROW('" & deg2 & "'!" & kap_dos_sütün_no & ":" & kap_dos_sütün_no & "))"
Cells(2, 5).Value = "=IF(ISERROR(" & yer2 & "),""""," & yer2 & ")"

son2 = Cells(2, 5).Value ' Kapalı dosyaya ait son dolu satır sayısı
Cells(2, 4).Value = son1
Cells(2, 5).Value = son2
sut1 = Cells(2, 4).Value ' Kapalı dosyaya ait son dolu sütun sayısı
sat1 = Cells(2, 5).Value ' Kapalı dosyaya ait son dolu satır sayısı

bas_satir_no = Cells(Rows.Count, "A").End(3).Row + 1

For r = sat1 To sat1 ' Kapalı dosyaya ait son dolu satır sayısı

Cells(bas_satir_no, 1) = Dosya.Name
Cells(bas_satir_no, 2) = SayfaAdi

kaydır = 3
For t = 1 To 12
If SayfaAdi = Cells(1, kaydır) Then
Cells(bas_satir_no, kaydır).Value = ExecuteExcel4Macro(deg3 & r & "C" & 2) 'kapalı dosyadaki değerlere ait prosüdür
Cells(bas_satir_no, kaydır + 1).Value = ExecuteExcel4Macro(deg3 & r & "C" & 4) 'kapalı dosyadaki değerlere ait prosüdür
End If
kaydır = kaydır + 2

Next t


bas_satir_no = bas_satir_no + 1

Next r

Atla1:
Next mat

End If

Atla2:
Next

On Error GoTo sonraki
For Each f In fs.GetFolder(yol).SubFolders
Liste9 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[moebius06]

hocam...
çok teşekkürler....zahmet olmuş...elinize sağlık
ben farklı klasörleri tek klasöre toplayıp, forumdaki örneklerden yararlanarak daha basit bir şey yapmıştım..( işim acil olduğu için )
ama sizin çalışmanıza göre tekrar düzenleme yapacağım..
tekrar teşekkür ederim...