• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

txt dosyasından veri alma

F

fkalelinet

Katılım
15 Nisan 2009
Mesajlar
122
Excel Vers. ve Dili
MSOPP2019TR-64bit
txt ve sql den veri alma

siteden bulduğum makro bu şekilde

Sub txt_veri_al()
Dim i As Long, deg As String, sat As Long, deg2, k As Byte, dosya
Range("A1:A65536").Clear
ChDir (ThisWorkbook.Path)
dosya = Application.GetOpenFilename(filefilter:="Metin dosyaları(*.txt),(*.txt)", Title:="Bir metin dosyası seçiniz.")
If dosya = False Then Exit Sub
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
Line Input #1, deg
sat = sat + 1
deg2 = Split(deg, vbTab)
k = 0
For i = 0 To UBound(deg2)
k = k + 1
Cells(sat, k).Value = deg2(i)
Next i
Loop
Close #1
Application.ScreenUpdating = True
MsgBox "veri.txt dosyasından veriler alınmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"


End Sub



ayrıca txt dosyasındaki ilk satırı almak istemiyorum. bunun için nerede ne gibi bir değişiklik yapmam gerekiyor.

ayrıca txt dosyam şu sekilde
Tue Dec 10 00:00:00 2013 35.3 288.0 17.7 0.4
dolayısı ile Tue Dec 10 00:00:00 2013 kısmını tek hücreye yazıyor.
35.3 288.0 17.7 0.4 kısımlarını istediğim gibi ayrı ayrı. ben
Tue Dec 10 00:00:00 2013 kısmını da ayrı ayrı hücrelere yazmak istiyorum. veri al metin bağlantılarında ayırıcı olarak sekme ve boşluk seçince yapabiliyordum. makroda bunu nasıl yapmam gerekir acaba. yani bu hem sekme hem boşluk seçim girişini hangi satırda nasıl yapıyoruz?

son olarak da excel dosyamın bir sayfasındaki bir hücrede sürekli değişen yani tarihe göre değişen txt dosyasının adı ve yolu var d:\winpmrapor\dk\dk20131212 gibi bu yol sheet1 au hücresinde ve başka bir hücreden tarihi referans alıp kendini değiştiriyor.
makroda dosyayı buradan otomatik al demek istesem dosya= kısmında mı değişiklik yapmam gerekiyor. yani dosya yolunu tablodaki herhangi bir hücreden alabilirmiyim.

teşekkürler.
 

Ekli dosyalar

Son düzenleme:
en az 3 konu açtım ancak sanırım yoğunluktan cevap alamadım. bende kurcalaya kurcalaya bişeyler yaptım. şuan tablomun içerisindeki bir hücreden dosya ile ilgili değişken bilgiyi alıp txt dosyasını açıp istediğim sütun ve satırdan başlamak üzere istediğim sayfaya aktarabiliyorum. ancak 2 sorunum var.
birisi;
Tue Dec 10 00:00:00 2013 kısmını tek hücreye yazıyor.
bunu çözebilmek için ayraç kısmına 2 ayrı ayraç tanımlamam gerekiyor sanırım. vbtab yada " " gibi birkaç ayraç ile ayırmalı.
ikincisi. txt dosyasındaki ilk satırı almak istemiyorum bunu nasıl engelleyebilirim.
ve son olarak da bu makroyu otomatik olarak sayfa açılınca açılsın ve her 1dk yada 5 dk da bir otomatik yenilesin yapabilirmiyim.
son kod aşağıdadır.

Sub Txt_Dosyasından_Excele_Al()

Dim Rky As String, dosyam As String
Dim Ert As Long, satır As Long, sütun As Long, i As Long
Dim ayır As Variant

dosyam = "d:\winpmrapor\dk\" & Sayfa2.Range("a1").Value & ".txt"
Ert = FreeFile

On Error Resume Next
Open dosyam For Input As #Ert

If Err.Number <> 0 Then
MsgBox "Text Dosyası Bulunamadı !", vbCritical, "Hata !"
Exit Sub
End If

On Error GoTo 0
Sayfa3.Cells.Clear
satır = 2

Do While Not EOF(Ert)
Line Input #Ert, Rky
ayır = Split(Rky, vbTab)
With Sayfa3
sütun = 1
For i = LBound(ayır) To UBound(ayır)
.Cells(satır, sütun) = ayır(i)
sütun = sütun + 1
Next i
End With
satır = satır + 1
Loop
Close #Ert

End Sub
 

Ekli dosyalar

Kod: 
Sub TEKDEN_KTT_()

'text dosyasının ilk satırından itibaren veri alır excelin 8.satırından itibaren aktarır.
'zcd 2/8 2013 IE kodlu optikden veri alacak şekilde ziya kılıç tarafından düzenlenmiştir.
Dim i As Long, deg As String, sat As Long, deg2, k As Byte, Dosya
                                                                                                                          
            Sheets("Sayfa1").Select
            Cells.FormatConditions.Delete
                                                                                                                          
        Range("C8:DU207").Sort Key1:=[DU7], Order1:=xlAscending
        Range("C8:BE207").ClearContents
        Satır = 7
        ChDir (ThisWorkbook.Path)
Dosya = Application.GetOpenFilename(FileFilter:="Metin dosyaları(*.txt),(*.txt)", Title:="Bir metin dosyası seçiniz.")
If Dosya = False Then Exit Sub
        Sheets("Sayfa1").Select
        Application.ScreenUpdating = True
Open Dosya For Input As #1
Do While Not EOF(1)
Line Input #1, kayıt


            Satır = Satır + 1
            Cells(Satır, 3) = Mid(kayıt, 23, 5)                ' Numarası
            Cells(Satır, 4) = Convert(Mid(kayıt, 1, 10))       'ADI
            Cells(Satır, 5) = Convert(Mid(kayıt, 11, 10))      ' SOYADI
            Cells(Satır, 6) = Convert(Mid(kayıt, 28, 1))       ' KİTAPÇIK TÜRÜ
            Cells(Satır, 7).NumberFormat = "@"
            Cells(Satır, 7) = Mid(kayıt, 21, 2)                ' SINIFI
                                                                                                                          
            Cells(Satır, 8) = Mid(kayıt, 32, 1)        '            1
            Cells(Satır, 9) = Mid(kayıt, 33, 1)        '            2
            Cells(Satır, 10) = Mid(kayıt, 34, 1)       '            3
            Cells(Satır, 11) = Mid(kayıt, 35, 1)       '            4
            Cells(Satır, 12) = Mid(kayıt, 36, 1)       '            5
            Cells(Satır, 13) = Mid(kayıt, 37, 1)       '            6
            Cells(Satır, 14) = Mid(kayıt, 38, 1)       '            7
            Cells(Satır, 15) = Mid(kayıt, 39, 1)       '            8
            Cells(Satır, 16) = Mid(kayıt, 40, 1)       '            9
            Cells(Satır, 17) = Mid(kayıt, 41, 1)       '            10
            Cells(Satır, 18) = Mid(kayıt, 42, 1)       '            11
            Cells(Satır, 19) = Mid(kayıt, 43, 1)       '            12
            Cells(Satır, 20) = Mid(kayıt, 44, 1)       '            13
            Cells(Satır, 21) = Mid(kayıt, 45, 1)       '            14
            Cells(Satır, 22) = Mid(kayıt, 46, 1)       '            15
            Cells(Satır, 23) = Mid(kayıt, 47, 1)       '            16
            Cells(Satır, 24) = Mid(kayıt, 48, 1)       '            17
            Cells(Satır, 25) = Mid(kayıt, 49, 1)       '            18
            Cells(Satır, 26) = Mid(kayıt, 50, 1)       '            19
            Cells(Satır, 27) = Mid(kayıt, 51, 1)       '            20
            Cells(Satır, 28) = Mid(kayıt, 52, 1)       '            21
            Cells(Satır, 29) = Mid(kayıt, 53, 1)       '            22
            Cells(Satır, 30) = Mid(kayıt, 54, 1)       '            23
            Cells(Satır, 31) = Mid(kayıt, 55, 1)       '            24
            Cells(Satır, 32) = Mid(kayıt, 56, 1)       '                        25
           Cells(Satır, 33) = Mid(kayıt, 57, 1)       '            26
           Cells(Satır, 34) = Mid(kayıt, 58, 1)       '            27
           Cells(Satır, 35) = Mid(kayıt, 59, 1)       '            28
           Cells(Satır, 36) = Mid(kayıt, 60, 1)       '            29
           Cells(Satır, 37) = Mid(kayıt, 61, 1)       '            30
           Cells(Satır, 38) = Mid(kayıt, 62, 1)       '            31
           Cells(Satır, 39) = Mid(kayıt, 63, 1)       '            32
           Cells(Satır, 40) = Mid(kayıt, 64, 1)       '            33
           Cells(Satır, 41) = Mid(kayıt, 65, 1)       '            34
           Cells(Satır, 42) = Mid(kayıt, 66, 1)       '            35
           Cells(Satır, 43) = Mid(kayıt, 67, 1)       '            36
           Cells(Satır, 44) = Mid(kayıt, 68, 1)       '            37
           Cells(Satır, 45) = Mid(kayıt, 69, 1)       '            38
           Cells(Satır, 46) = Mid(kayıt, 70, 1)       '            39
           Cells(Satır, 47) = Mid(kayıt, 71, 1)       '            40
           Cells(Satır, 48) = Mid(kayıt, 72, 1)       '                        41
           Cells(Satır, 49) = Mid(kayıt, 73, 1)       '            42
           Cells(Satır, 50) = Mid(kayıt, 74, 1)       '            43
           Cells(Satır, 51) = Mid(kayıt, 75, 1)       '            44
           Cells(Satır, 52) = Mid(kayıt, 76, 1)       '            45
           Cells(Satır, 53) = Mid(kayıt, 77, 1)       '            46
           Cells(Satır, 54) = Mid(kayıt, 78, 1)       '            47
           Cells(Satır, 55) = Mid(kayıt, 79, 1)       '            48
           Cells(Satır, 56) = Mid(kayıt, 80, 1)       '            49
           Cells(Satır, 57) = Mid(kayıt, 81, 1)       '            50
           Cells(Satır, 58) = Mid(kayıt, 82, 1)       '            51
  
  
                                                                                                                          
    Loop
    Close #1
    Cells.EntireColumn.AutoFit
    MsgBox "İŞLEM TAMAM"
        Sheets("Anasayfa").Select
End Sub
Function Convert(Veri As String)
Veri = Replace(Veri, Chr(154), "Ü")
Veri = Replace(Veri, Chr(166), "Ğ")
Veri = Replace(Veri, Chr(158), "Ş")
Veri = Replace(Veri, Chr(128), "Ç")
Veri = Replace(Veri, Chr(153), "Ö")
Veri = Replace(Veri, Chr(152), "İ")
Convert = Replace(Veri, Chr(15), "")
End Function
 
. . .

Uyarı:

Merhaba maymun37,

İletilerinizde yer alan kodları
Kod: 
 tagları içerisinde yazmanız, okunaklılığını arttıracaktır.
[URL="http://www.excel.web.tr/f14/checkbox-ile-secimli-yazdyrma-t135771/post735448.html"][B][I][COLOR="Red"]Tıkla ~ Code Tag Kullanımı Hk.[/COLOR][/I][/B][/URL]

. . .
 
hocam zaten benim kodlar direk hücreden alıp ilgili satır ve sütundan başlayacak şekilde yazıyor. bana sadece bunlar lazım. sizin kodları düznlemeye çalışmak ölüm txti kendin seçiyorsun ve manuel yapıyorsun. uzun iş yani. benim tahminim benim kodlara az biraz ekleme lazım olacak sadece. araştırıyorum kendim de diğer siteler dahil ama çözdükce yazarım. ama sadece lazım olan 2 sorunum var. birisi;
Tue Dec 10 00:00:00 2013 kısmını tek hücreye yazıyor.
bunu çözebilmek için ayraç kısmına 2 ayrı ayraç tanımlamam gerekiyor sanırım. vbtab yada " " gibi birkaç ayraç ile ayırmalı.
ikincisi. txt dosyasındaki ilk satırı almak istemiyorum bunu nasıl engelleyebilirim.
ve son olarak da bu makroyu otomatik olarak sayfa açılınca açılsın ve her 1dk yada 5 dk da bir otomatik yenilesin yapabilirmiyim.
son kod aşağıdadır.


Kod: 
Sub Txt_Dosyasından_Excele_Al()

Dim Rky As String, dosyam As String
Dim Ert As Long, satır As Long, sütun As Long, i As Long
Dim ayır As Variant

dosyam = "d:\winpmrapor\dk\" & Sayfa2.Range("a1").Value & ".txt"
Ert = FreeFile

On Error Resume Next
Open dosyam For Input As #Ert

If Err.Number <> 0 Then
MsgBox "Text Dosyası Bulunamadı !", vbCritical, "Hata !"
Exit Sub
End If

On Error GoTo 0
Sayfa3.Cells.Clear
satır = 2

Do While Not EOF(Ert)
Line Input #Ert, Rky
ayır = Split(Rky, vbTab)
With Sayfa3
sütun = 1
For i = LBound(ayır) To UBound(ayır)
.Cells(satır, sütun) = ayır(i)
sütun = sütun + 1
Next i
End With
satır = satır + 1
Loop
Close #Ert

End Sub
 
txt dosyasından veri alma makrosu otomatik olarak sayfa açılınca açılıyor ve istenilen ve ayarlanan sürede otomatk olarak gelen verileri yeniliyor.
kaldı 2 sorunum birisi
Tue Dec 10 00:00:00 2013 kısmını tek hücreye yazıyor.
ikincisi ise
txt dosyasındaki ilk satırı almak istemiyorum bunu nasıl engelleyebilirim.

yardımcı olacak arkadaş var mı?. ben araştırmaya devam ediyorum çözersem eklerim yine buraya.

Ama önce Cuma'yı Eda Etmek lazım :)

Kod: 
Sub Auto_Open()
    
    Application.OnTime Now + TimeValue("00:05:00"), "Auto_Open"
    Dim Rky As String, dosyam As String
    Dim Ert As Long, satır As Long, sütun As Long, i As Long
    Dim ayır As Variant

    dosyam = "d:\winpmrapor\dk\" & Worksheets("DK-OZET").Range("a1").Value & ".txt"
    Ert = FreeFile
    
    On Error Resume Next
    Open dosyam For Input As #Ert

    If Err.Number <> 0 Then
        MsgBox "Text Dosyası Bulunamadı !", vbCritical, "Hata !"
        Exit Sub
    End If
    
    On Error GoTo 0
    Worksheets("DKK").Cells.Clear
    satır = 1
    
    Do While Not EOF(Ert)
        Line Input #Ert, Rky
        ayır = Split(Rky, vbTab)
        With Worksheets("DKK")
            sütun = 1
            For i = LBound(ayır) To UBound(ayır)
                .Cells(satır, sütun) = ayır(i)
                sütun = sütun + 1
            Next i
        End With
        satır = satır + 1
    Loop
    Close #Ert

End Sub
 
Son düzenleme:
bu kodu kullanınca çok yavaş çekiyor satır satır eski nokta vuruşlu yazıcılar gibi sıkıntı veriyor. aşağıdaki kod ile bir nebze daha hızlı alıyorum ancak bi kod vardı sayfada sitede paylaşılmış her seferinde ayrı bir sayfada açıyordu dosyaları ve çok daha hızlı alıyordu bilgileri. onu tekrar bulamadım.
ve split koduyla iki ayrı ayırıcı kullanmayı hala başaramadım.

Kod: 
Sub TXT_Ac()
    Dim dosya As String, d As String
    Dim s As Long
    Dim st, i As Integer
    
    On Error Resume Next
    
    dosya = "d:\winpmrapor\dk\" & Worksheets("DK").Range("z1").Value & ".txt"

    If dosya = "False" Then Exit Sub
    Open dosya For Input As #1
        While Not EOF(1)

            s = s + 1
            Line Input #1, d
                     st = 0
                     x = Split(d, vbTab)
                    For i = 0 To UBound(x)
                        st = st + 1
                        If x(i) = "" And i > 0 Then
                        st = st - 1
                        GoTo atla
                        End If
                        Cells(s, st) = x(i)
atla:
                    Next i
            
        Wend
    Close #1

End Sub
 
sql çekerken makro kullanımında ki sorun için de sql scripti kopyala yapıştır ile veri çekebilmem lazım. aşağıdaki kodda sorunlarım var
Kod: 
Sub AMBAR()
Application.ScreenUpdating = False
Set s1 = Sheets("PARAMETRE")


Sheets("LISTE").Select
Range("a2:f50000").ClearContents
Range("a1").Select

userf = s1.Cells(6, 2)
sifre = s1.Cells(7, 2)
server = s1.Cells(8, 2)
veritabani = s1.Cells(9, 2)
FIRMA = s1.Cells(10, 2)


kod1 = "'" & s1.Cells(1, 2) & "'"
kod2 = "'" & s1.Cells(2, 2) & "'"


baglan = "ODBC;DRIVER=SQL Server;SERVER=" & server & ";UID=" & userf & ";PWD=" & sifre & ";APP=Microsoft Office XP;WSID=BIM-LIZBUDAK;DATABASE=" & veritabani

alan1 = "SELECT  " & FIRMA & "ITEMS.LOGICALREF, " & FIRMA & "ITEMS.CODE AS 'KODU', " & FIRMA & "ITEMS.NAME AS 'AÇIKLAMA'"
alan2 = " FROM " & veritabani & ".dbo." & FIRMA & "ITEMS " ' & FIRMA & "ITEMS"
alan3 = " WHERE (" & FIRMA & "ITEMS.CODE>=" & kod1 & ") AND (" & FIRMA & "ITEMS.CODE<=" & kod2 & ")"
alan4 = " ORDER BY  " & FIRMA & "ITEMS.CODE"

'S1.Cells(50, 1) = alan1 & alan2 & alan3 & alan4

With Selection.QueryTable

     .Connection = baglan
     .CommandText = alan1 & alan2 & alan3 & alan4
     .Refresh BackgroundQuery:=False


 End With

End Sub
 

Ekli dosyalar

koşullu sadece istenene text dosyayssını alabiliriz bi deneyeceğim ama aranacak veri için tüm dosyyaı tarıyor sadece ilk satırı tarayabilir mi,?
Kod: 
Sub Read_Large_File_2()  
      
    Dim FileName   As String  
    Dim FileNum    As Integer  
    Dim ResultStr  As String  
      
    Dim wsSheet    As Worksheet  
    Dim strValues() As String  
      
    Dim lngRows    As Long  
    Dim lngRow     As Long  
    Dim intSheet   As Integer  
    Dim intCounter As Integer  
      
    FileName = Application.GetOpenFilename(Textdateien  & _  
    (*.txt; *.csv),*.txt; *.csv)  
      
        If FileName =  Or FileName = Falsch Then Exit Sub  
    FileNum = FreeFile()  
      
    Open FileName For Input As #FileNum  
    Application.ScreenUpdating = False  
    Workbooks.Add template:=xlWorksheet  
      
    lngRows = ActiveSheet.Rows.Count  
    lngRow = 1  
    intSheet = 1  
    ReDim strValues(lngRows, 1)  
      
    Application.StatusBar = Blatt  & intSheet &  wird eingelesen  
      
    Do While Seek(FileNum) <= LOF(FileNum)  
        Line Input #FileNum, ResultStr  
        If Left(ResultStr, 1) = = Then  
            strValues(lngRow, 1) =  & ResultStr  
        Else  
            strValues(lngRow, 1) = ResultStr  
        End If  
        If lngRow < lngRows Then  
            lngRow = lngRow + 1  
        Else  
            ActiveSheet.Range(A1:A & lngRows) = strValues  
            ActiveWorkbook.Worksheets.Add after:=Worksheets(Worksheets.Count)  
      
            ReDim strValues(lngRows, 1)  
            lngRow = 1  
            intSheet = intSheet + 1  
            Application.StatusBar = Blatt  & intSheet &  wird eingelesen  
        End If  
    Loop  
    Close  
    ActiveSheet.Range(A1:A & lngRows) = strValues  
      
    If MsgBox(Sollen die eingelesenen Daten auf Spalten verteilt werden?, _  
        vbYesNo, Text in Spalten) = vbNo Then  
        Application.ScreenUpdating = True  
        Application.StatusBar = Fertig  
        Exit Sub  
    End If  
      
    intSheet = 0  
    For Each wsSheet In ActiveWorkbook.Worksheets  
        intSheet = intSheet + 1  
        Application.StatusBar = Daten von Blatt  & intSheet _  
        &  werden bearbeitet  
        With wsSheet  
            .Range(A:A).TextToColumns Destination:=.Range(A1), _  
            DataType:=xlDelimited, _  
            TextQualifier:=xlDoubleQuote, _  
            ConsecutiveDelimiter:=False, _  
            Tab:=False, _  
            Semicolon:=True, _  
            Comma:=False, _  
            Space:=False, _  
            Other:=False  
        End With  
    Next wsSheet  
    Application.ScreenUpdating = True  
    Application.StatusBar = Fertig  
End Sub

Kod: 
Const yol = "C:\genel.TXT"

Sub DosyadanAl2()
Sheets("Genel2").Select
  satir = 1
  Open yol For Input As 1
    Do While Not EOF(1)
      Line Input #1, kayit1
      If kayit1 <> Empty Then
        Cells(satir, 1) = kayit1
        satir = satir + 1
      End If
    Loop
  Close #1
 End Sub

Sub nn()

Sheets("genelx").Select
s = InputBox("Ayrım Hangi Satırdan Başlayacak")
s2 = InputBox("Ayrım Hangi Satırda Bitecek")
If s = "" Or s2 = "" Then Exit Sub
h = InputBox("Aktarım Hangi Hücreden Başlayacak")
x = Range(h).Row - 1
y = Range(h).Column - 1
For i = s To s2
x = x + 1
c = y
For j = 1 To 6
    a = Split("  " & Sheets("genel2").Cells(i, j), "  ")
For tt = 1 To UBound(a)
If a(tt) <> Empty Then c = c + 1: Cells(x, c) = Replace(a(tt), "-", "")
Next
Next
Next
End Sub
Sub Temizle()
If ActiveCell = Empty Then MsgBox "Silmek İstediğiniz Bölgeyi Tarayınız": Exit Sub
Selection.Clear
End Sub

Kod: 
Sub VeriAl()
Dim sat As Long
Range("A:A").ClearContents
Dim ds, dc, s, a
Set ds = CreateObject("Scripting.FileSystemObject")
Set dc = ds.Drives
For Each sürücü In dc
s = s & vbCrLf & sürücü
yer = sürücü & "\ornek.txt"
a = ds.FileExists(yer)
If a = True Then
MsgBox yer & " Bu isimde bir dosya " & sürücü & " sünde var"
Open yer For Input As #1
Do While Not EOF(1)
Input #1, a
If a <> Empty Then
sat = sat + 10
Cells(sat, "A") = a
End If
Loop
Close #1
Exit Sub
End If
Next
End Sub
 
bunları da deneedim ancak hem boşluk hem tab a göre dosyaayı çekmek mümkün değil sanırım. makro ile.
 

Ekli dosyalar

tüm denenmiş örnek kodları görüp deneyebileceğim eğitimvideolu bi bölüm vardı. göremiyorum şimdi bulamıyorum da. nasıl ulaşırım acaba.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst