Kapalı dosyalardan sutun başlıklarına göre veri alma hk.

[kemal turan]

Merhaba,
Kapalı dosyalarda verilerim var, bu ana dosya şablonuma göre veriler farklı sutunlarda veya bazıları olmayabiliyor.
İsteğim ile ilgili örnek dosya ek te gönderilmiştir.
Not: Bu veri olan dosyalar toplamda 40 adet olabiliyor ve her defasında tarih eklendiği için çalışma kitabı adı farklı olabiliyor.
yazılacak kodda her defasında doğru adres vermek gerekir diye düşünüyorum.
Bunu sağlamak için gelen dosya adlarını dosya1, dosya2, dosya3 şeklinde değiştirebiliriz.
Veya dosya adı ne olursa olsun klasör içerisinde mevcut bütün çalışma kitaplarını açıp verileri alması mümkün ise bu da olabilir.
Çok önemli olan bu kod için yardımlarınızı bekliyorum.
Teşekkür ederim.

 

[haliliyas]

dosyanızı harici bir siteye yüklemeniz mümkün mü?

 

[kemal turan]

Kusura bakmayın,
Excelweb tr harici sitelere hiç dosya yüklemedim.

 

[haliliyas]

• Google Drive
• WeTransfer
• Mega
• Dropbox
• OneDrive
• File Dropper
• MediaFire
• Sendspace
• Filemail
• MailBigFile
• Transfernow
• Sendthisfile
• Send Anywhere

 

[haliliyas]

aşağıdaki kodu dener misiniz?
1 - veri alınacak excel dosyları aktif excel dosyası ile aynı dizinde olmalı, istenirse değiştirilebilir
2 - sadece xlsx dosyalarından veri alır istenirse değiştirilebilir
3 - son satırı bulma kodu sorun çıkarabilir, bütün excel sayfasına baktığından tablo dışındaki alanlardaki dolu satırlar da hesaba katılıyor
dolu olması gereken, mecburi bir sütun varsa son satır ona göre de bulunabilir.
Not: sadece belirttiğiniz 5 sütun için (C, D, L, M, N SUTUNLARI ) işlem yapılmıştır

Sub Ekle_ADO_1()
'hy__________________________________________Excel Excel Bağla referanssız
'referanslı kullanılacaksa önce referanslardan Microsoft ActiveX Data Object x.x library eklenmeli
t1 = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False
Set syf = ThisWorkbook.Worksheets("VERILER")
Dim dz(4) As Variant
    dz(0) = syf.Range("C1")
    dz(1) = syf.Range("D1")
    dz(2) = syf.Range("L1")
    dz(3) = syf.Range("M1")
    dz(4) = syf.Range("N1")
Dim dzA As Variant
       
Dim SQL As String
Dim xCn As Object
Dim xRs As Object

Set xCn = CreateObject("Adodb.Connection")
Set xRs = CreateObject("adodb.recordset")

yol = ThisWorkbook.Path & "\"
Set evn = CreateObject("scripting.filesystemobject")
Set klasor = evn.getfolder(yol)

For Each ds In klasor.Files
If Left(ds.Name, 1) = "~" Or evn.GetExtensionName(ds) <> "xlsx" Or ds.Name = ThisWorkbook.Name Then GoTo TmpCik
   
    xCn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ds & ";Extended Properties=""Excel 12.0;HDR=Yes"""
    xCn.Open
   
    xSQL = "select * from [Sayfa1$]"
        xRs.Open xSQL, xCn, 3, 1
        ReDim dzA(1 To xRs.Fields.Count)
        For x = 1 To xRs.Fields.Count:           dzA(x) = xRs(x - 1).Name:        Next x
        xAlan = ""
       
'If IsNumeric(Application.Match(dz(0), dzA, 0)) Then xAlan = xAlan & "[" & dz(0) & "]" & "," Else xAlan = xAlan & "'',"
'If IsNumeric(Application.Match(dz(1), dzA, 0)) Then xAlan = xAlan & "[" & dz(1) & "]" & ",'','','','','','',''," Else xAlan = xAlan & "'','','','','','','','',"
'If IsNumeric(Application.Match(dz(2), dzA, 0)) Then xAlan = xAlan & "[" & dz(2) & "]" & "," Else xAlan = xAlan & "'',"
'If IsNumeric(Application.Match(dz(3), dzA, 0)) Then xAlan = xAlan & "[" & dz(3) & "]" & "," Else xAlan = xAlan & "'',"
'If IsNumeric(Application.Match(dz(4), dzA, 0)) Then xAlan = xAlan & "[" & dz(4) & "]" Else xAlan = xAlan & "''"

    xRs.Close
xAlan = "[Importer],[Country Name],'','','','','','','',[Weight(KG)],[Total Price(USD)],[Average Price(USD/Kg)]"
For Each itm In dz
    If Not IsNumeric(Application.Match(itm, dzA, 0)) Then xAlan = Replace(xAlan, "[" & itm & "]", "''")
Next
xSQL = "select " & xAlan & " from [Sayfa1$]"

    xRs.Open xSQL, xCn, 3, 1
    sonstr = syf.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1

    syf.Range("C" & sonstr).CopyFromRecordset xRs
    xCn.Close

TmpCik:
Next ds

Set xRs = Nothing
Set xCn = Nothing
Application.EnableEvents = True
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
MsgBox "bitti. Süre : " & Timer - t1 & " saniye"
End Sub

 

[kemal turan]

Merhaba,
Biraz rahatsızım şirkete gittiğimde en kısa sürede dönüş yapacağım.
Çok teşekküre ederim. Emeğinize sağlık
Selametle kalınız

 

[haliliyas]

Rica ederim
İyi çalışmalar

 

[kemal turan]

Çok teşekkür ederim. Umarım ki çok kişi bu kodlardan faydalanacak.
Selametle kalın

 

[haliliyas]

rica ederim
siz de selametle kalın