Ado ile kapalı txt veri alma hk.

[sekozzy]

Merhaba arkadaşlar,
daha önceden kapalı excel dosyasından veri alma için kullandığım bir kodu txt için düzenlemek istedim ama pek başarılı olamadım. VBA konusunda çok iyi değilim. Bu nedenle sizden rica etsem aşağıdaki kodları txt alabilmem için düzenler misiniz rica etsem?

EXCELden VERİ ALMA KODUM:

Sub excel_veri_al()
Dim Baglanti, rs As Object
With Sheets("ExcelVeriAl")
    Range("I4:R98").ClearContents
    Set Baglanti = CreateObject("ADODB.Connection")
    dosya_yolu = .Range("U1").Text
    dosya_donemi = .Range("U2").Text
    dosya_adi = .Range("U3").Text
    dosya_gunu = .Range("A4").Text
    dosya = dosya_yolu & "\" & dosya_donemi & "\" & dosya_gunu & "\" & dosya_adi & ".xlsm"
    If Dir(dosya) = Empty Then
        MsgBox dosya_adi & ".xlsm" & Chr(10) & "Adlı Dosya Bulunamadı!", vbCritical, "Hata !"
    Exit Sub
    End If
    Baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=no"""
    Set rs = Baglanti.Execute("select f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,f11,f12,f13,f14,f15,f16,f17,f18,f19,f20,f21,f22,f23,f24,f25,f26,f27,f28,f29,f30,f31,f32,f33,f34,f35,f36,f37,f38,f39,f40,f41,f42 from [GünSonu$] where not isnull(f1)")
    .Range("I4").CopyFromRecordset rs
End With
    Set Baglanti = Nothing
    Set rs = Nothing
End Sub

Yardımcı olursanız memnun olurum. İyi çalışmalar.

 

[Erdem Akdemir]

Örnek dosya ekleyebilir misiniz.

 

[sekozzy]

Erdem bey,
verdiğim kod ile herhangi bir excel dosyasından veri alıyorum. Aynı şekilde herhangi bir text dosyasından veri almak istiyorum. Kodları aşağıdaki şekilde sadeleştirdim anlaşılır olması açısından.

Sub excel_veri_al()
Dim Baglanti, rs As Object
With Sheets("ExcelVeriAl")
    Range("D4:M98").ClearContents
    Set Baglanti = CreateObject("ADODB.Connection")
    Baglanti.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\Kapalı_Dosya.xlsx" & ";extended properties=""excel 12.0;hdr=no"""
    Set rs = Baglanti.Execute("select * from [Sayfa1$]")
    .Range("D4").CopyFromRecordset rs
End With
    Set Baglanti = Nothing
    Set rs = Nothing
End Sub

Bu kod ile kapalı bir excel dosyasından veri alıyorum. Bunu text dosyası için nasıl düzenlemem gerekiyor?

 

[Erdem Akdemir]

Text dosyanızın yapısını görmek gerek.

 

[Erdem Akdemir]

Merhaba,

Yol yazan kısmı siz değiştirirsiniz.
Örnek olarak kullanabilirsiniz.

Sub txtado()

Set con = CreateObject("ADODB.Connection")

yol = "C:\Users\" & Environ("UserName") & "\Desktop\"

x = "deneme.txt"

con.Open _
"Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & yol & ";Extended Properties=""text;HDR=No;FMT=Delimited"""

sorgu = "select * from deneme.txt"
Set rs = con.Execute(sorgu)
Range("a1").CopyFromRecordset rs

End Sub

 

[sekozzy]

Merhaba,

Yol yazan kısmı siz değiştirirsiniz.
Örnek olarak kullanabilirsiniz.

Sub txtado()

Set con = CreateObject("ADODB.Connection")

yol = "C:\Users\" & Environ("UserName") & "\Desktop\"

x = "deneme.txt"

con.Open _
"Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & yol & ";Extended Properties=""text;HDR=No;FMT=Delimited"""

sorgu = "select * from deneme.txt"
Set rs = con.Execute(sorgu)
Range("a1").CopyFromRecordset rs

End Sub

Merhaba,
öncelikle yardımcı olduğunuz için teşekkür ederim. Ben örnek dosyaya gerek kalacağını düşünmemiştim. Kusura bakmayın.
Not: Dosya ismi ve yolu değişken olduğu için ilk verdiğim kodda olduğu gibi değişken tanımlamıştım. Ayrıca dosya adı GG.AA.YYYY şeklinde tarih ve boşluk içermekte olduğundan kodda bulunan x e dosya adını girdiğimde kod hata verdi.

 

[sekozzy]

Merhaba arkadaşlar,
Dosya adı tarih formatı şeklinde yazıldığı ve boşluk içerdiği için sorguda hata veriyor. Bu problemi nasıl çözerim Bilgisi olan yardımcı olabilir mi rica etsem.

 

[Haluk]

Alan adında (yani, dosya adında) boşluk varsa, köşeli parantez içinde kullanmak gerekir. ....... [Dosya Adı] gibi.

Ancak, sizdeki sorun; dosya adı olan tarih biçiminde "nokta" kullanılmasından kaynaklanıyor.

Masaüstündeki "Text" dosyasının adını 19-11-2018 DOSYASI olarak değiştirin, kodu da bu şekilde kullanın.

Sub txtado()

Set con = CreateObject("ADODB.Connection")

yol = "C:\Users\" & Environ("UserName") & "\Desktop"

x = "19-11-2018 DOSYASI.txt"

con.Open _
"Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & yol & ";Extended Properties=""text;HDR=No;FMT=Delimited"""

sorgu = "select * from [" & x & "]"
Set rs = con.Execute(sorgu)
Range("a1").CopyFromRecordset rs

End Sub

.

 

[sekozzy]

Alan adında (yani, dosya adında) boşluk varsa, köşeli parantez içinde kullanmak gerekir. ....... [Dosya Adı] gibi.

Ancak, sizdeki sorun; dosya adı olan tarih biçiminde "nokta" kullanılmasından kaynaklanıyor.

Masaüstündeki "Text" dosyasının adını 19-11-2018 DOSYASI olarak değiştirin, kodu da bu şekilde kullanın.

Sub txtado()

Set con = CreateObject("ADODB.Connection")

yol = "C:\Users\" & Environ("UserName") & "\Desktop"

x = "19-11-2018 DOSYASI.txt"

con.Open _
"Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & yol & ";Extended Properties=""text;HDR=No;FMT=Delimited"""

sorgu = "select * from [" & x & "]"
Set rs = con.Execute(sorgu)
Range("a1").CopyFromRecordset rs

End Sub

.

Haluk bey, verdiğiniz bilgi için teşekkür ederim. Fakat bu dosyalar otomatik olarak oluşturulmakta. Zaten bu kodun kullanımındaki amaçta bu otomatik gelen dosyaların içinden lazım olan verileri süzüp kullanmak istememizden kaynaklanıyor. Dosya isimlerini değiştirmek yerine o formatı okutmak bi şekilde mümkündür diye düşünüyorum.
1.mesajımdaki kodlarda excel dosyalarındaki verileri çekiyorum. O kodlarda da aynı tarih formatı kullanılmakta ama sorunsuz veri çekebilmekteyim. Bu yüzden mümkün olabileceği kanısına vardım. Yanılıyorsam da kusuruma bakmayın bu konuda tam bilgi sahibi olmadığım için yanlış düşünüyor olabilirim.

 

[halit3]

Merhaba soru ado ile veri almak ama alternatif olsun diye farklı olarak dosyayı text açıp kopyala yapıştır ile veri alıyor.

Sub verial2()
yol = ThisWorkbook.Path

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Text Files", "*.txt", 1
.FilterIndex = 3
.InitialFileName = yol
.Show
'.Execute
If .SelectedItems.Count = 0 Then GoTo atla2
dosya = .SelectedItems(1)
sat = 4

Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")

If LCase(fs.GetExtensionName(dosya)) = "txt" Then
Data1 = ThisWorkbook.Name
Workbooks.OpenText Filename:=dosya, DataType:=xlDelimited, Tab:=True
        
If WorksheetFunction.CountA(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells) > 0 Then
sat = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ActiveWorkbook.Worksheets(ActiveSheet.Name).Range(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(1, 1), ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(sat, sut)).Copy
ThisWorkbook.Sheets("Sayfa1").Paste Destination:=ThisWorkbook.Sheets("Sayfa1").Range("a1")

End If

Application.DisplayAlerts = False
ActiveWindow.Close
End If

atla2:

MsgBox "işlem tamam ", vbOKOnly + vbInformation, "uyarı"
End With

End Sub

 

[Haluk]

Başka bir yöntem deneyelim;

Dosyada M1 hücresine, dosya adını yazın ...... (Örnek olarak; 19.11.2018 DOSYASI.txt)

Sonra, Excel dosyanıza bir modül ilave edip, aşağıdaki kodu deneyin ...

Sub Test()
    'Haluk - 22/11/2018
    '
    Range("A1:A" & Rows.Count) = Empty
    MyPath = "C:\Users\" & Environ("UserName") & "\Desktop\"
    MyFile = Range("M1").Text
    
    Open MyPath & MyFile For Input As #1
        strFile = Input(LOF(1), #1)
    Close #1
    
    myArr = Split(strFile, vbCrLf)
    
    For lineNo = 0 To UBound(myArr)
        Cells(lineNo + 1, 1) = myArr(lineNo)
    Next
End Sub

.

 

[Erdem Akdemir]

Klasör yapınızı tam bilmiyorum ama aşağıdaki kod ile ADO'yu kullanarak alabilirsiniz.
Eskiad kısmı önemli orayı FileSystemObject nesnesi ve Dir komutu ile bulabilirsiniz.

Sub txtado()

Cells.Clear
Dim ds, f
Set ds = CreateObject("Scripting.FileSystemObject")

yol = "C:\Users\" & Environ("UserName") & "\Desktop\"

eskiad = yol & "19.11.2018 DOSYASI.txt"
yeniad = yol & "19-11-2018 DOSYASI.txt"
Name eskiad As yeniad

f = ds.GetFileName(yeniad)

Set con = CreateObject("ADODB.Connection")

con.Open _
"Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & yol & ";Extended Properties=""text;HDR=No;FMT=Delimited"""


sorgu = "select * from [" & f & "]"

Set rs = con.Execute(sorgu)
Range("a1").CopyFromRecordset rs
con.Close

Name yeniad As eskiad

End Sub

 

[sekozzy]

Klasör yapınızı tam bilmiyorum ama aşağıdaki kod ile ADO'yu kullanarak alabilirsiniz.
Eskiad kısmı önemli orayı FileSystemObject nesnesi ve Dir komutu ile bulabilirsiniz.

Sub txtado()

Cells.Clear
Dim ds, f
Set ds = CreateObject("Scripting.FileSystemObject")

yol = "C:\Users\" & Environ("UserName") & "\Desktop\"

eskiad = yol & "19.11.2018 DOSYASI.txt"
yeniad = yol & "19-11-2018 DOSYASI.txt"
Name eskiad As yeniad

f = ds.GetFileName(yeniad)

Set con = CreateObject("ADODB.Connection")

con.Open _
"Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & yol & ";Extended Properties=""text;HDR=No;FMT=Delimited"""


sorgu = "select * from [" & f & "]"

Set rs = con.Execute(sorgu)
Range("a1").CopyFromRecordset rs
con.Close

Name yeniad As eskiad

End Sub

Klasör yapısı ekte resimlerle verilmiştir.
1.mesajımda verdiğim kod ile excel dosyalarındaki veriyi bu klasör yapısına göre alabiliyorum.
İstediğim şey ise aynı işlemi txt dosyaları için de yapabilmek.
Şuana kadar verilen kodlar aslında çalışıyor fakat

1.si A4 hücresine girilen tarihe göre K4 hücresinden başlayacak şekilde veri çekmek istiyorum.
2.si txt'den gelen verinin tek sütunda sıralanmasını değil sütunlara bölünmüş şekilde gelmesini istiyorum. (mümkünse)
2.nci madde mümkün değilse istediğim verileri parça al fonksiyonu ile almam gerekecek.
3.sü Klasör ismi örneğin; 31.10.2018 ise içindeki text dosyasının dosya adı 1 gün sonrası yani 01.11.2018'dir.

Bu nedenle 1.mesajda kullandığım kodda

dosya_yolu = .Range("U1").Text 'D:\HESAP
dosya_donemi = .Range("U2").Text '2018 YILI\E-POSTA GELENLER\NOKTA1\2018 - 11 KASIM\20.11.2018
dosya_adi = .Range("U3").Text '21.11.2018 DOSYASI
dosya_gunu = .Range("A4").Text 'Tarih
dosya = dosya_yolu & "\" & dosya_donemi & "\" & dosya_gunu & "\" & dosya_adi & ".xlsm"[/CODE]

Kırmızı işaretli alanlar değişken ve A4 hücresine girilen tarihe göre değişmektedir.

 

[Haluk]

Text dosyasındaki verileri Excel'de sütunlara bölmek için;

Sub Test2()
    MyPath = "C:\Users\" & Environ("UserName") & "\Desktop\"
    MyFile = Range("M1").Text

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & MyPath & MyFile, Destination:=Range("$A$1"))
        .Name = "Test"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 857
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileDecimalSeparator = "."
        .TextFileThousandsSeparator = ","
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

.

 

[Haluk]

Veya; Text dosyasındaki verileri Excel'de sütunlara bölmek için aşağıdaki alternatif de kullanılabilir.

Sub Test3()
    'Haluk - 22/11/2018
    '
    Range("A1:J" & Rows.Count) = Empty
    MyPath = "C:\Users\" & Environ("UserName") & "\Desktop\"
    MyFile = Range("M1").Text
   
    Open MyPath & MyFile For Input As #1
        strFile = Input(LOF(1), #1)
    Close #1
   
    myArr = Split(strFile, vbCrLf)
   
    For lineNo = 0 To UBound(myArr)
        myArr2 = Split(myArr(lineNo), vbTab)
        For j = 0 To UBound(myArr2)
            Cells(lineNo + 1, j + 1) = myArr2(j)
        Next
    Next
End Sub

.

 

[sekozzy]

Arkadaşlar, konu isteğimin dışına çıktığı için en baştan alıyorum.
1.si istemiş olduğum işlem ADO ile veri çekme kodudur. (Şuan mevcut kullandığım kod kopyalama yöntemiyle sütunlara ayırıyor fakat çok yavaş)
2.si ADO ile isteme nedenim işlemin hızlı gerçekleşmesi.
3.sü Klasör yapısını ve örnek dosyayı önceki mesaj eklerinde verdim.
4.sü Text dosyalarının adı 25.11.2018 DOSYASI.txt örneğinde olduğu gibi tarih formatı ile başlamaktadır.
5.si Kodda 4 adet değişken olacak, bunlar;
dosya_yolu = .Range("U1").Text 'D:\HESAP\2018 YILI\E-POSTA GELENLER\NOKTA1\
dosya_donemi = .Range("U2").Text '2018 - 10 EKİM\
dosya_tarihi = .Range("U3").Text '31.10.2018\
dosya_adi = .Range("U4").Text '01.11.2018.txt
Kırmızı işaretli yerler U1, U2, U3 ve U4 hücresinden gelecek. U3 hücresine girilen tarihe göre diğer hücrelerdeki değerler formül aracılığıyla değişecek. Böylece kod içindeki tanımlı değişkenlere de istenilen yıl, dönem, tarih ve dosya adı gelecek.
6.sı ADO ile çekilen veri sütunlara bölünmüş olacak. (eğer mümkünse tabiki, sütunlara bölünmesi işimi kolaylaştırır)

Aslında Erdem Bey'in son mesajında vermiş olduğu kod istediğimi yapmakta fakat değişkenleri tanımladığımda sanırım dosya adı tarih formatlı başladığı için kod hata veriyor. Erdem Bey'in son vermiş olduğu kod üzerine istemiş olduğum değişkenleri tanımlayabilirseniz ve sütunlara bölebilirseniz sorunum çözülmüş olacak. Sizin için basit olabilen çözümler bilmeyenler için dağ gibi büyük sorunlar olabiliyor ne yazık ki. Hakkınızı helal edin arkadaşlar. Sizleri yorduğum için özür dilerim.

 

[Erdem Akdemir]

Merhaba,

Sorunuzla ilgilenmek istiyorum ama çok fazla şey talep etmişsiniz.
En basitten başlayarak ufak örneklerle parça parça gidersiniz sizde öğrenmiş olursunuz. Soruyu cevaplamak isteyenleri de kaçırmamış olursunuz.

ADO ile veri alırken delimiter'de özel ayraç belirtemiyoruz diye biliyorum ama tam emin değilim. Bu tarz işlemler için schema.ini adında bir dosya oluşturularak daha düzgün veri çekildiğini internette gördüm. Bizim sitede de Zeki Gürsoy'un bununla ilgili bir çalışması var. Önce onları incelemenizi tavsiye ederim.

 

[sekozzy]

Anladım Erdem Bey,
özel ayraç olmadan devam edelim o halde. Sizin en son vermiş olduğunuz kodda dosya adı değişkenini tarih formatlı okutmamız mümkün değil mi? Dosya isimleri 20.11.2018 DOSYASI.txt, 21.11.2018 DOSYASI.txt, 22.11.2018 DOSYASI.txt şeklinde gidiyor. Siz daha önce dosya isimlerini 20-11-2018 DOSYASI.txt şeklinde değiştirirseniz sorun çözülür demiştiniz ama dosya isimleri sistem tarafından oluşturuluyor. Dosya isimlerine girip tek tek değiştirmektense isimleri olduğu şekilde okutmanın bir yöntemi yok mu?

 

[Erdem Akdemir]

Son eklediğim kod'da dosya isimleri ile ilgili olan sorunu çözmüştük.
Şimdi sizin yapmanız gereken, veri alınacak bir klasör yapısı ,örnek txt ve verinin excel' de nasıl görüneceğini gösteren bir örnek.
Dosyaların hepsini zip'li olarak eklerseniz daha iyi olur.

 

[sekozzy]

Erdem Bey, ekteki dosyada kopyalama yöntemiyle çalışan makro kodu mevcut.
rar dosyası içinde bulunan HESAP klasörünü D:\ içine atıp makroyu çalıştırırsanız istediğimi anlayacaksınız.
diyeceksiniz ki bu kod çalışıyor peki senin derdin ne benim derdim o kodun veriyi tek tek satır satır alması nedeniyleyavaş çalışıyor olması. Ama ADO ile veriyi tek seferde excele aktarıyor. ADO dışında başka bir yöntemle de aynı işlemi yapabilirseniz benim için sorun yok. Bana vakit ayırdığınız ve sorularıma yanıt verdiğiniz için teşekkür ederim. İyi çalışmalar