Toplu veri çekme excel yardım

[marka212]

merhaba iyi geceler arkadaşlar sizden söle bir ricam olucak mümkün ise fatura kesmek için su sekilde bir şeye ihtiyacım var Fatura kesim excel dosyası aynı klasorde bulununan tum excel dosyalarındaki verilerin cekilmesini
istiyorum eger mümkünse ornek bir dosya ekledim ordaki verileri manuel olarak fatura kesim dosyasına attım s tablosu ile v tablosu arasına bir buton ornek koydum tıkladıgımda verileri cekmesi için her excel'de bazen 3 bazen 20 dosya olabiliyor fatura kesim dosyasında ise aylık toplamda bazen 100 bazen 500 veri olabiliyor bana bu konuda yardımcı olabilirmisiniz

 

[halit3]

merhaba iyi geceler arkadaşlar sizden söle bir ricam olucak mümkün ise fatura kesmek için su sekilde bir şeye ihtiyacım var Fatura kesim excel dosyası aynı klasorde bulununan tum excel dosyalarındaki verilerin cekilmesini
istiyorum eger mümkünse ornek bir dosya ekledim ordaki verileri manuel olarak fatura kesim dosyasına attım s tablosu ile v tablosu arasına bir buton ornek koydum tıkladıgımda verileri cekmesi için her excel'de bazen 3 bazen 20 dosya olabiliyor fatura kesim dosyasında ise aylık toplamda bazen 100 bazen 500 veri olabiliyor bana bu konuda yardımcı olabilirmisiniz

Bu kod klasördeki dosyaların Sayfa1 sayfasında C sütunundaki son dolu satıra kadar olan verileri listeliyor.

Dim sat As String
Dim Sayfa_adı As String
Dim deg1
Dim deg2



Sub CommandButton1_Click()

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("2:" & Rows.Count).Interior.ColorIndex = xlNone
End If


Cells(1, 4).NumberFormat = "General"
Cells(1, 5).NumberFormat = "General"

deg1 = Cells(1, 4).Value
deg2 = Cells(1, 5).Value

Sayfa_adı = ActiveSheet.Name

sat = 2

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
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
Liste (Klasor.Items.Item.Path)
Cells(1, 4).Value = deg1
Cells(1, 5).Value = deg2


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 Liste(yol As String)
Dim fs As Object, f As Object

Set fs = CreateObject("Scripting.FileSystemObject")

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


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

Uzanti = fs.GetExtensionName(Dosya.Name)

If aranan_Uzanti = "xlam" Then
If Uzanti = "xls" Or Uzanti = "xlsm" Or Uzanti = "xlsx" Or Uzanti = "xlsb" Then
Else
GoSub atla
End If
End If


If aranan_Uzanti = "xla" Then
If Uzanti <> "xls" Then
GoSub atla
Else
End If
End If


If ThisWorkbook.Name <> Dosya.Name Then

Kalasor2 = fs.GetParentFolderName(Dosya)
If Right(Kalasor2, 1) <> "\" Then Kalasor2 = Kalasor2 & "\"




SayfaAdi = "Sayfa1"


If SayfaAdi = "" Then GoSub atla


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

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

son1 = 0
son2 = 0



kap_dos_sütün_no = "c"
kap_dos_satir_no = 2


yer1 = "LOOKUP(2,1/('" & deg3 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "<>""""),COLUMN('" & deg3 & "'!" & kap_dos_satir_no & ":" & kap_dos_satir_no & "))"
Cells(1, 4).Value = "=IF(ISERROR(" & yer1 & "),""""," & yer1 & ")"
'Cells(1, 4).Value = Cells(1, 4).Value


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

Cells(1, 4).Value = Cells(1, 4).Value
Cells(1, 5).Value = Cells(1, 5).Value
sut1 = Cells(1, 4).Value ' Kapalı dosyaya ait son dolu sütun sayısı

sat1 = Cells(1, 5).Value ' Kapalı dosyaya ait son dolu satır sayısı


deg9sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

If deg9sat >= 2 Then
bas_satir_no = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
Else
bas_satir_no = 2        'aktarılacak veriye ait başlangıç satır numarası
End If



If Val(sut1) = 0 Or Val(sat1) = 0 Then MsgBox "son dolu satır ve son dolu sütunda değer yok": GoSub atla
If Val(veri_alinacak_bas_sat) > Val(sat1) Then MsgBox "veri alınacak başlangıç satır son dolu satırdan büyük olamaz.": GoSub atla
If Val(veri_alinacak_bas_sut) > Val(sut1) Then MsgBox "veri alınacak başlangıç satır son dolu sütundan büyük olabaz": GoSub atla



Cells(bas_satir_no, 1) = Dosya
Cells(bas_satir_no, 1).Interior.ColorIndex = 8
bas_satir_no = bas_satir_no + 1


For r = veri_alinacak_bas_sat To sat1 ' Kapalı dosyaya ait son dolu satır sayısı
say = bas_satun_no
For j = veri_alinacak_bas_sut To sut1 ' Kapalı dosyaya ait son dolu sütun sayısı
Cells(bas_satir_no, say).Value = ExecuteExcel4Macro(deg4 & r & "C" & j) 'kapalı dosyadaki değerlere ait prosüdür
If Cells(bas_satir_no, say).Value = 0 Then
Cells(bas_satir_no, say).Value = ""
End If

Cells(bas_satir_no, 1).Select
say = say + 1
Next j

bas_satir_no = bas_satir_no + 1

If Rows.Count - 1 <= r Then Exit For
Next r

'Atla1:
atla:
'End If
'Atla2:
End If

Next

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

Set fL = Nothing
End Sub

 

[halit3]

merhaba iyi geceler arkadaşlar sizden söle bir ricam olucak mümkün ise fatura kesmek için su sekilde bir şeye ihtiyacım var Fatura kesim excel dosyası aynı klasorde bulununan tum excel dosyalarındaki verilerin cekilmesini
istiyorum eger mümkünse ornek bir dosya ekledim ordaki verileri manuel olarak fatura kesim dosyasına attım s tablosu ile v tablosu arasına bir buton ornek koydum tıkladıgımda verileri cekmesi için her excel'de bazen 3 bazen 20 dosya olabiliyor fatura kesim dosyasında ise aylık toplamda bazen 100 bazen 500 veri olabiliyor bana bu konuda yardımcı olabilirmisiniz

Konuları karıştırdınız herhalde bu konu başlığı altında sorduğunuz soruya 2 nolu mesajda cevap verilmiştir.

 

[marka212]

halil bey ellerinize saglık mukemmel olmus beni gereksiz bir külfiyetten kurtardınız allah razı olsun

 

[halit3]

halil bey ellerinize saglık mukemmel olmus beni gereksiz bir külfiyetten kurtardınız allah razı olsun

Teşekkürler iyi çalışmalar

 

[feridici_genc]

İyi geceler.
Halit bey kodlarınıza değişiklik için yardım edermisiniz?
Kaynak dosyaların sadece B, E, I, K, M sütunlarını almak istiyorum. Nasıl yapabilirim?

 

[feridici_genc]

Bu dosya üzerindeki verileri almaya çalışıyorum. Bunun gibi 38 dosya daha var.
Yardım edin lütfen.