.txt dosyasındaki aratılan verileri çekmek

[toricelli]

Sevgili üstadlar,
Elimde verilerimi sakladığım txt dökümanlarım var. Bu text dosya sayısı 1000i geçiyor.
İçeriğinde müvekkil adı , soyadı, adresi , telefonu, eposta adresi, hesabı, bakiye gibi bilgiler var. Her bir bilgi virgül ile ayrılmış şekilde saklı.
Ben excel sayfasında bir text dosyasındaki verileri atarak, diğer sayfadan düşeyara formülüyle bilgi alabiliyorum.
Ancak ne var ki, text dosyaları çok fazla ve verileri excele aktarmak oldukça zahmetli.
Özetle, birden fazla text dosyasından virgülle ayrılmış verileri, excel sayfasından ada göre, soyada göre veya eposta adresine göre aratıp, ilgili kişinin bütün bilgilerini çekebileceğim bir sistem var mı?
Ya da nasıl yapabilirim. Excelde sadece formüllerle uğraşıyorum makro konusunda çok acemiyim.
Teşekkürler

 

[Orion1]

Bir tane örnek txt dosyası ekleyiniz.

 

[toricelli]

Sevgili üstadım,
Yazının ekine dosyayı ekledim. İçindeki bilgileri sallama yaptım. Şimdi elimde 1000'e yakın ve her bir txt dosyasında da 1000e yakın bu şekilde bilgi var. Excel tablosuna txt içindeki uyap kimlik no, adı, soyadı gibi bilgileri yazdıktan sonra, kimliğe göre ara, ada göre ara gibi kriterlerle bu bilgileri txt dosyasından çekmek istiyorum.
Bu arada hızlı cevabınız için teşekkür ederim.

 

[Orion1]

txt dosyalar ve excel dosyası ayni klasör içinde olmalıdır.
Dosyanız ektedir.

Sub kimlik_ara()
Dim deg As String, kimlik, deg2, sut As Byte
Dim fso As Object, fs As Object, dosya As String, sat As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Range("A6:F65536").ClearContents
sat = 6
If Range("B1").Value = "" Then
    MsgBox "Lütfen kimlik No giriniz.", vbCritical, "UYARI"
    Range("B1").Select
    Exit Sub
End If
If Not IsNumeric(Range("B1").Value) Then
    MsgBox "Kimlik No sayısal bir değer olmalıdır." & vbLf & "Arama yapılmadı.", vbCritical, "UYARI"
    Range("B1").Select
    Exit Sub
End If
On Error Resume Next
For Each fs In fso.getfolder(ThisWorkbook.Path).Files
    dosya = fs.Name
    If Right(dosya, 4) = ".txt" Then
        Open (fs) For Input As #1
            Do While Not EOF(1)
                Input #1, deg
                deg2 = Split(deg, ";")
                kimlik = deg2(LBound(deg2))
                If CStr(Range("B1").Value) = kimlik Then
                    sut = 2
                    Cells(sat, "A").Value = dosya
                    For i = LBound(deg2) To UBound(deg2)
                        Cells(sat, sut).Value = deg2(i)
                        sut = sut + 1
                    Next
                    sat = sat + 1
                End If
            Loop
        Close #1
    End If
Next fs
Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
Sub ad_soyad()
Dim deg As String, ad, deg2, sut As Byte
Dim fso As Object, fs As Object, dosya As String, sat As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
Range("A6:F65536").ClearContents
sat = 6
If Range("B2").Value = "" Then
    MsgBox "Lütfen ad soyad giriniz.", vbCritical, "UYARI"
    Range("B2").Select
    Exit Sub
End If
ad = UCase(Replace(Replace(Range("B2").Value, "ı", "I"), "i", "İ"))
On Error Resume Next
For Each fs In fso.getfolder(ThisWorkbook.Path).Files
    dosya = fs.Name
    If Right(dosya, 4) = ".txt" Then
        Open (fs) For Input As #1
            Do While Not EOF(1)
                Input #1, deg
                deg2 = Split(deg, ";")
                If UCase(Replace(Replace(deg2(1) & " " & deg2(2), "ı", "I"), "i", "İ")) = ad Then
                    sut = 2
                    Cells(sat, "A").Value = dosya
                    For i = LBound(deg2) To UBound(deg2)
                        Cells(sat, sut).Value = deg2(i)
                        sut = sut + 1
                    Next
                    sat = sat + 1
                End If
            Loop
        Close #1
    End If
Next fs
Application.ScreenUpdating = True
MsgBox "Aktarım tamamlandı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[toricelli]

Üstadım mükemmel olmuş. Eline emeğine sağlık. Küçük bir problem var. Txt dosyaları utf8 olarak kayıtlı. Veri çekerken karakterlerde bozulma oluyor. Bunun için bir çözüm yolu bulunabilir mi? Uğratıracak birşey ise, en kötü dosyaları ansi olarak kaydederim.
Tekrar teşekkürler.

 

[halit3]

alternatif kod

Sub deneme()
Cells.ClearContents
b = Application.GetOpenFilename
If b = False Then
Exit Sub
End If

i = 1
Open Dir(b) For Input As #1
Do While Not EOF(1)
Line Input #1, a
Cells(i, 1).Value = a
i = i + 1
Loop
Close
ayır
End Sub

Sub ayır()
Columns("A:A").Select

For i = 1 To Worksheets(ActiveSheet.Name).[A65536].End(3).Row
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=";", FieldInfo:=Array(Array(i, 1), Array(i, 2), Array(i, 3))
ActiveWindow.ScrollColumn = 2
Next i
Columns("A:F").EntireColumn.AutoFit
Range("A1").Select
End Sub

 

[Orion1]

Üstadım mükemmel olmuş. Eline emeğine sağlık. Küçük bir problem var. Txt dosyaları utf8 olarak kayıtlı. Veri çekerken karakterlerde bozulma oluyor. Bunun için bir çözüm yolu bulunabilir mi? Uğratıracak birşey ise, en kötü dosyaları ansi olarak kaydederim.
Tekrar teşekkürler.

Range("A6:F65536").ClearContents

aşğıdaki ile dğiştir.

Range("A6:IV65536").ClearContents

 

[toricelli]

Range("A6:F65536").ClearContents

aşğıdaki ile dğiştir.

Range("A6:IV65536").ClearContents

olmadı üstad.

BAŞ AYŞE
bu şekilde çıkıyor.

 

[Orion1]

Üstadım mükemmel olmuş. Eline emeğine sağlık. Küçük bir problem var. Txt dosyaları utf8 olarak kayıtlı. Veri çekerken karakterlerde bozulma oluyor. Bunun için bir çözüm yolu bulunabilir mi? Uğratıracak birşey ise, en kötü dosyaları ansi olarak kaydederim.
Tekrar teşekkürler.

olmadı üstad.

BA� AY�E
bu şekilde çıkıyor.

Yukırda dediğğinizi yaptınızmı?

 

[toricelli]

Hmm, tamam üstad. Normalde utf-8 olarak kayıtlı dosyayı ansi'ye çevirdikten sonra, son bahsettiğiniz değişiklik çalıştı.
İlginize, emeğinize teşekkür ederim.

 

[Orion1]

Hmm, tamam üstad. Normalde utf-8 olarak kayıtlı dosyayı ansi'ye çevirdikten sonra, son bahsettiğiniz değişiklik çalıştı.
İlginize, emeğinize teşekkür ederim.

Rica ederim.
iyi çalışmalar.