Text dosyasından excele Veri Alma

[hlojan]

x y z adlı text dosyalarından alınan verileri düzenleyerek excel e aktarmak istiyorum

Örnek klasör ektedir.

Text dosyalarında veriler

X 1.235

Y 0.001

X 1.212

Y 0,002

bu şekilde .

• her satırdaki boşlukları almaması
• x,y leri değerlerden ayırma X VE Y sütunlarına ayırma
• her değer noktalı . her değeri virgüllü sayı formatına çevirmesi
• 0 a yakın değerleri iptal etme 0,001 -0,001 0,000 0,002 gibi
• 3 text dosyasından bütün x ve y değerlerini toparlayıp x ve y sütununda toparlama

Ek dosyada ekledim

Konu hakkında yardımlarınızı bekliyorum

 

[Haluk]

Merhaba, WinRar gibi bir şey olmadığı için eklediğiniz dosyayı indirmedim.

Diğer yandan, bu istedikleriniz makro ile yapılır tabii ama; eğer bu işi sık sık yapmıyorsanız elle de Excel'in bazı işlevlerini kullanarak yapılabilir gibi görünüyor.

 

[hlojan]

Sık kullanıyorum
hergün 20 kere filan

dosyaları ekledim

 

[halit3]

veri alınacak dosyalar ile verilerin yazılacağı dosya aynı klasörde olmalı

Sub text_veri_al()
Worksheets(ActiveSheet.Name).Range("A2:b65000").ClearContents
Liste1 (ThisWorkbook.Path)
MsgBox "işlem tamam"

End Sub
Private Sub Liste1(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
If LCase(fL.GetExtensionName(Dosya)) = "txt" Then

say1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A" & Rows.Count)) + 2
say2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B" & Rows.Count)) + 2

aranan1 = "X"
aranan2 = "Y"
bulunan1 = "&"

Open Dosya For Input As #1

Do While Not EOF(1)
Line Input #1, veri

veri = Mid(veri, 1, 1) & "&" & Mid(veri, 2, 100)
veri = Replace(Replace(Replace(Replace(veri, " ", ""), Chr(10), ""), Chr(9), ""), ".", ",")

deg1 = Split(Trim(veri), bulunan1)
If UBound(deg1) > 0 Then

If deg1(1) <= 0.001 Then GoTo Atla

If deg1(0) = aranan1 Then
Cells(say1, 1) = deg1(1) * 1
say1 = say1 + 1
End If

If deg1(0) = aranan2 Then
Cells(say2, 2) = deg1(1) * 1
say2 = say2 + 1
End If
End If

Atla:
Loop
Close #1

End If
Next

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

End Sub

 

[Haluk]

Merhaba;

Ben de kendi hazırladığım alternatifi paylaşmak istedim.

Bunun için ilk önce söz konusu text dosyalarını;

C:\TestFolder\TextDosyalari\x.txt
C:\TestFolder\TextDosyalari\y.txt
C:\TestFolder\TextDosyalari\z.txt

olacak şekilde bilgisayarda yerleştirdim. Daha sonra, aşağıdaki kodları bir modüle yerleştirip, MAIN isimli makroyu çalıştırdım.

Sub MAIN()
    Dim Dosya1 As String, Dosya2 As String, Dosya3 As String
    Range("B1") = "X"
    Range("C1") = "Y"
    Dosya1 = "C:\TestFolder\TextDosyalari\x.txt"
    Dosya2 = "C:\TestFolder\TextDosyalari\y.txt"
    Dosya3 = "C:\TestFolder\TextDosyalari\z.txt"
    Call TEXT_DOSYASINDAN_VERI_AL(Dosya1)
    Call TEXT_DOSYASINDAN_VERI_AL(Dosya2)
    Call TEXT_DOSYASINDAN_VERI_AL(Dosya3)
End Sub
'
Private Sub TEXT_DOSYASINDAN_VERI_AL(DosyaAdi As String)
    Open DosyaAdi For Input As #1
    Do While Not EOF(1)
        Line Input #1, InputData
        Data = Right(InputData, Len(InputData) - 1)
        Data = WorksheetFunction.Substitute(Data, " ", "")
        Data = WorksheetFunction.Substitute(Data, ".", ",")
        LastRowB = Cells(65536, 2).End(xlUp).Row
        LastRowC = Cells(65536, 3).End(xlUp).Row
        If (Data + 0) > 0.001 Then
            If Left(InputData, 1) = "X" Then
                Cells(LastRowB + 1, 2) = Data
            ElseIf Left(InputData, 1) = "Y" Then
                Cells(LastRowC + 1, 3) = Data
            End If
        End If
    Loop
    Close #1
End Sub