Birden çok txt dosyada arama ve veri çekme

jajiyiko · 7 Haziran 2016

Merhaba!

Öncelikle herkese iyi ramazanlar diliyorum.

Şöyle bir sorunum var;

Bir klasör içinde değişik adlarla kayıtlı birden çok .txt uantılı dosyalar var.

Her dosyanın içinde,

"11.10.2016", ahmet mehmet, 123456789,500,2500,12000,"İSTANBUL","34100"
"19.12.2016", ismail eren, 8500025122,1500,2500,12000,"ANKARA","06000"
"11.10.2016", ahmet mehmet, 123456789,500,2500,12000,"İSTANBUL","34100"
"19.12.2016", hasan hüseyin, 8500025122,1500,2500,12000,"ANKARA","06000"

gibi binlerce kayıt var.

Mesela klasördeki tüm txt dosyalarını tarayıp içinde 19.12.2016 , 12000 ve ANKARA olan satırları seçip excel de sayfa1 deki a1 hücresine yazdırabilirmiyiz?

Teşekkür ederim.

Asri · 8 Haziran 2016

Linkteki dosyayı inceleyiniz.

Aranacak kelimeler de VE , YADA koşullarını kullanabilir siniz.

http://asriakdeniz.com/excel-text-dosyadan-coklu-arama-ve-veri-alma/

jajiyiko · 8 Haziran 2016

Cevabınız için teşekkür ederim. Ancak bendeki ofis 2003 versiyon. Dosyayı çalıştıramadım.

Teşekkürler

Asri · 8 Haziran 2016

jajiyiko' Alıntı:
Cevabınız için teşekkür ederim. Ancak bendeki ofis 2003 versiyon. Dosyayı çalıştıramadım.

Teşekkürler

Hangi aşama hata verdi. Ekran görüntüsü paylaşabilir mi siniz?

jajiyiko · 8 Haziran 2016

Merhaba!

Bende Ofis 2003 yüklü olduğu için hiç açamıyorum. Excel 2003 ile açmaya çalıştığımda "Bu dosya biçim tanınmıyor" gibi bir hata veriyor.

Siz farklı kaydet ile ofis 2003 olarak kaydedebilirseniz o zaman açabilirim sanırım.

Teşekkürler

Asri · 9 Haziran 2016

2003 olarak kaydettim, ancak çalışmasını deneyemedim.

Deneyip bilgi verir mi siniz?

http://s4.dosya.tc/server/uu4zal/Excel_Text_Dosyalarinda_Coklu_Arama.xls.html

alicimri · 9 Haziran 2016

Alternatif bir çalışma. Kodlardaki kırmızı yerlerdeki dosya yolunu kendinize göre değiştirin.

Kod:

Sub Makro1()
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder[COLOR="red"]("D:\txtler\[/COLOR]")
    Set fc = f.Files
    For Each f1 In fc
    Workbooks.OpenText Filename:="[COLOR="Red"]D:\txtler\[/COLOR]" & f1.Name, _
        Origin:=936, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
        Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1)), _
        TrailingMinusNumbers:=True

    Rows("1:1").Select
    Selection.Insert Shift:=xlDown
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "a1"
    Selection.AutoFill Destination:=Range("A1:H1"), Type:=xlFillDefault
    Selection.AutoFilter
    Selection.AutoFilter Field:=1, Criteria1:="19.12.2016"
    Selection.AutoFilter Field:=7, Criteria1:="ANKARA"
    Selection.AutoFilter Field:=6, Criteria1:="12000"
      say0 = ActiveSheet.Range("A65536").End(3).Row + 1
     Range("A2:H" & say0).Copy
   
     Workbooks(1).Activate
    say = ActiveSheet.Range("A65536").End(3).Row + 1
    ActiveSheet.Range("a" & say).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
        Application.DisplayAlerts = False
        Workbooks(2).Close
         Application.DisplayAlerts = True
         Next
End Sub

alicimri · 9 Haziran 2016

Sayın asri
2003 Excel de "can't find project or library" hatası veriyor.

jajiyiko · 9 Haziran 2016

Mehaba

sayın asri

refences den microsoft wort 11.0 object library ekleyince kodunuz çalıştı.

sayın alicimri

kodunuzda "CTRL- END" basın gibi bir hata verdi.

Herkese teşekkür ederim. Emeğiniz için hakkınızı helal edin.

Saygılar

Asri · 9 Haziran 2016

alicimri' Alıntı:
Sayın asri
2003 Excel de "can't find project or library" hatası veriyor.

2003 kurulu olmadığı için deneyememiştim.

Sayın jajiyiko, sorunu çözmüş.

halit3 · 10 Haziran 2016

Alternatif kod:
Kodun çalışması için aranan verileri A sütununa sırasıyla boş satır bırakmadan yazın ve kodu çalıştırın bulunan değerleri b sütununa yazmaktadır.

Kod:

Sub mevcut_dosyaları_bul()

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
Columns("b").ClearContents
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files

If LCase(fL.GetExtensionName(Dosya)) = "txt" Then

Open Dosya For Input As #1
Do While Not EOF(1)
Line Input #1, a

For i = 1 To Cells(Rows.Count, "a").End(3).Row
aranan = Cells(i, 1).Value

If InStr(Trim(a), aranan) > 0 Then
'If UBound(Split(a, aranan)) > 0 Then
son = Cells(Rows.Count, "B").End(3).Row + 1
Cells(son, 2).Value = Trim(a)
Exit For
End If

Next

Loop
Close
End If

Next

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

Set fL = Nothing
End Sub

Asri · 10 Haziran 2016

halit3' Alıntı:
Alternatif kod:
Kodun çalışması için aranan verileri A sütununa sırasıyla boş satır bırakmadan yazın ve kodu çalıştırın bulunan değerleri b sütununa yazmaktadır.

Kod:

Sub mevcut_dosyaları_bul() ...... If InStr(Trim(a), aranan) > 0 Then 'If UBound(Split(a, aranan)) > 0 Then son = Cells(Rows.Count, "B").End(3).Row + 1 Cells(son, 2).Value = Trim(a) Exit For End If .....

@halit,
kodlar anladığım kadarı ile aranan değerler için OR olarak çalışıyor.
İlk soruda sanırım her aranan AND olarak aranmak isteniyor.

AND olarak da ayarlanabilirse yada seçenekli olursa daha iyi olacaktır.

halit3 · 10 Haziran 2016

Kod A ve B sutuna yazılı değeri aynı satırda aramakta ve bulduğunda satır numarası ve dosya adlarınıda yazmakta.

Kod:

Sub mevcut_dosyaları_bul()

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
Columns("c:g").ClearContents
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Cells(1, 3).Value = "Bulunan değer"
Cells(1, 4).Value = "Arananlar"
Cells(1, 5).Value = "Bulunan satır"
Cells(1, 6).Value = "Bulunan Adres"
Cells(1, 7).Value = "Bulunan Dosya adı"
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files

If LCase(fL.GetExtensionName(Dosya)) = "txt" Then
say = 0
Open Dosya For Input As #1
Do While Not EOF(1)
Line Input #1, a
say = say + 1
For i = 1 To Cells(Rows.Count, "a").End(3).Row
aranan1 = Cells(i, 1).Value
aranan2 = Cells(i, 2).Value
'If InStr(Trim(a), aranan) > 0 Then

'If UBound(Split(a, aranan1)) > 0 Then
If UBound(Split(a, aranan1)) > 0 And UBound(Split(a, aranan2)) > 0 Then
son = Cells(Rows.Count, "c").End(3).Row + 1
Cells(son, 3).Value = Trim(a)
Cells(son, 4).Value = aranan1 & " " & aranan2
Cells(son, 5).Value = say & " .Satır"
Cells(son, 6).Value = Dosya
Cells(son, 7).Value = Dosya.Name
Exit For
End If

Next

Loop
Close
End If

Next

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

Set fL = Nothing
End Sub

halit3 · 10 Haziran 2016

Bu kod da A,B,C sütünlarındaki (ikinci satırdan başlıyor) değerleri dikkate alarak bulduğu değeri, satırı, dosya adresini, dosya adını yazıyor.

Kodu çalıştırdığınızda metin belgelerinin bulunduğu klasörü seçmeniz yeterli.

Kod:

Sub mevcut_dosyaları_bul()

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
Columns("d:h").ClearContents
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Cells(1, 1).Value = "Aranan Değer 1"
Cells(1, 2).Value = "Aranan Değer 2"
Cells(1, 3).Value = "Aranan Değer 2"
Cells(1, 4).Value = "Bulunan değer"
Cells(1, 5).Value = "Arananlar"
Cells(1, 6).Value = "Bulunan satır"
Cells(1, 7).Value = "Bulunan Adres"
Cells(1, 8).Value = "Bulunan Dosya adı"
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, f As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files

If LCase(fL.GetExtensionName(Dosya)) = "txt" Then
say = 0
Open Dosya For Input As #1
Do While Not EOF(1)
Line Input #1, a
say = say + 1
For i = 2 To Cells(Rows.Count, "a").End(3).Row
aranan1 = Cells(i, 1).Value
aranan2 = Cells(i, 2).Value
aranan3 = Cells(i, 3).Value

evet = ""
bul = ""
If UBound(Split(a, aranan1)) > 0 And UBound(Split(a, aranan2)) > 0 And UBound(Split(a, aranan3)) > 0 Then
evet = "x"
bul = aranan1 & " " & aranan2 & " " & aranan3
ElseIf UBound(Split(a, aranan1)) > 0 And UBound(Split(a, aranan2)) > 0 Then
evet = "x"
bul = aranan1 & " " & aranan2
ElseIf InStr(Trim(a), aranan1) > 0 Then
evet = "x"
bul = aranan1
Else
evet = ""
End If

If evet = "x" Then
son = Cells(Rows.Count, "d").End(3).Row + 1
Cells(son, 4).Value = Trim(a)
Cells(son, 5).Value = bul
Cells(son, 6).Value = say & " .Satır"
Cells(son, 7).Value = Dosya
Cells(son, 8).Value = Dosya.Name
Exit For
End If


Next

Loop
Close
End If

Next

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

Set fL = Nothing
End Sub

alicimri · 10 Haziran 2016

Altrnatif bir çalışma

Kod:

Sub Makro1()
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder("D:\txtler\")
    Set fc = f.Files
    For Each f1 In fc
Workbooks.OpenText Filename:="D:\txtler\" & f1.Name, Origin:=28599, StartRow:=1, FieldInfo:=Array(1, 1)
        Rows("1:1").Insert Shift:=xlDown
    Columns("A:A").AutoFilter Field:=1, Criteria1:="=*19.12.2016**12000**ANKARA*", Operator:=xlAnd
        SAY = Range("A6536").End(3).Row
        Range("A2:A" & SAY).Copy
        SAY1 = Workbooks(1).Sheets(1).Range("A65536").End(3).Row + 1
        Workbooks(1).Sheets(1).Range("A" & SAY1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone
    Application.DisplayAlerts = False
       Workbooks(2).Close
       Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub

Birden çok txt dosyada arama ve veri çekme

jajiyiko

Asri

jajiyiko

Asri

jajiyiko

Asri

alicimri

alicimri

jajiyiko

Asri

halit3

Uzman

Asri

halit3

Uzman

halit3

Uzman

alicimri