Text dosyadan sırası belli satırları çekme

Tevfik_Kursun · 15 Mayıs 2023

Merhaba Arkadaşlar,
Ekli Deneme1.txt dosyasındaki bilgiler tamamen uydurmadır.
Bu dosyadaki tüm bilgileri yüklemeden belirli satırları excel dosyaya yüklemek istiyorum.
Örnek olarak : 5. 6. 11. 19. 22. satırdaki bilgiler A2 den itibaren sırayla nasıl alınabilir?
Saygılarımla

Haluk · 15 Mayıs 2023

C#:

Sub Test()
    'Haluk - 15/05/2023
    '
    Dim MyPath As String, MyFile As String, strData As String
    Dim arrLines() As Variant, myArr() As String, myArr2() As String
    Dim LineNo As Long, lngRow As Variant, j As Long
    
    MyPath = ThisWorkbook.Path & "\"
    MyFile = "Deneme1.txt"
    
    Range("A1:BV" & Rows.Count) = ""
    arrLines = Array(5, 6, 11, 19, 22)
    
    Open MyPath & MyFile For Input As #1
        strData = Input(LOF(1), #1)
    Close #1
    
    LineNo = 1
    
    For Each lngRow In arrLines
        LineNo = LineNo + 1
        
        myArr = Split(strData, vbCrLf)
        myArr2 = Split(myArr(lngRow - 1), vbTab)
        
        For j = LBound(myArr2) To UBound(myArr2)
            Cells(LineNo, j + 1) = Utf8ToUnicode(myArr2(j))
        Next
    Next
End Sub
'
Function Utf8ToUnicode(strText As String) As String
'   Haluk - 28/04/2020
'
    Dim objStream As Object, strRetVal As String
    
    Const adTypeText = 2
    Const adReadAll = -1
    
    Set objStream = CreateObject("ADODB.Stream")
    
    objStream.Open
    objStream.Charset = "Windows-1254"
    objStream.WriteText strText
    objStream.Position = 0
    objStream.Type = adTypeText
    objStream.Charset = "UTF-8"
    strRetVal = objStream.ReadText()
    objStream.Close
    
    Utf8ToUnicode = strRetVal
    Set objStream = Nothing
End Function

.

Erdem Akdemir · 15 Mayıs 2023

Haluk' Alıntı:

C#:

Sub Test()
    'Haluk - 15/05/2023
    '
    Dim MyPath As String, MyFile As String, strData As String
    Dim arrLines() As Variant, myArr() As String, myArr2() As String
    Dim LineNo As Long, lngRow As Variant, j As Long
   
    MyPath = ThisWorkbook.Path & "\"
    MyFile = "Deneme1.txt"
   
    Range("A1:BV" & Rows.Count) = ""
    arrLines = Array(5, 6, 11, 19, 22)
   
    Open MyPath & MyFile For Input As #1
        strData = Input(LOF(1), #1)
    Close #1
   
    LineNo = 1
   
    For Each lngRow In arrLines
        LineNo = LineNo + 1
       
        myArr = Split(strData, vbCrLf)
        myArr2 = Split(myArr(lngRow - 1), vbTab)
       
        For j = LBound(myArr2) To UBound(myArr2)
            Cells(LineNo, j + 1) = Utf8ToUnicode(myArr2(j))
        Next
    Next
End Sub
'
Function Utf8ToUnicode(strText As String) As String
'   Haluk - 28/04/2020
'
    Dim objStream As Object, strRetVal As String
   
    Const adTypeText = 2
    Const adReadAll = -1
   
    Set objStream = CreateObject("ADODB.Stream")
   
    objStream.Open
    objStream.Charset = "Windows-1254"
    objStream.WriteText strText
    objStream.Position = 0
    objStream.Type = adTypeText
    objStream.Charset = "UTF-8"
    strRetVal = objStream.ReadText()
    objStream.Close
   
    Utf8ToUnicode = strRetVal
    Set objStream = Nothing
End Function

.

Haluk bey elinize sağlık.

Korhan Ayhan · 15 Mayıs 2023

Deneyiniz.

Makrolu dosya ve TXT dosyası aynı klasörde olsun.

Not: Haluk bey cevaplamış ama bende yazmıştım. Boşa gitmesin diye paylaşıyorum.

C++:

Option Explicit

Sub Read_Txt_File()
    Dim My_File As String
    Dim My_Data As Variant
    Dim My_Split_Data As Variant
    Dim Row_Array As Variant
    Dim Last_Row As Long
    Dim X As Long

    Row_Array = Array(5, 6, 11, 19, 22)

    My_File = ThisWorkbook.Path & "\Deneme1.txt"

    My_Data = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(My_File, 1).ReadAll, vbNewLine)
    
    Range("A2").Resize(Rows.Count - 1, Columns.Count).ClearContents
    
    Last_Row = 2
    
    For X = LBound(Row_Array) To UBound(Row_Array)
        My_Split_Data = Split(My_Data(Row_Array(X) - 1), vbTab)
        Cells(Last_Row, 1).Resize(1, UBound(My_Split_Data)) = Split(My_Data(Row_Array(X) - 1), vbTab)
        Last_Row = Last_Row + 1
    Next
    
    Columns.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

dost · 15 Mayıs 2023

Merhaba,

Sayın @Haluk ve @Korhan Ayhan gerekli cevapları yazmış.

Türkçe sorununa gerçi @Haluk çözüm bulmuş ama, Sayın @Korhan Ayhan'ın yazmış olduğu kodda Türkçe karakterler için izninle ufak bir düzeltme yaptım.

Biraz araştırma yapmıştım, boşa gitmesin dedim

C++:

Sub Read_Txt_File()
    Dim My_File As String
    Dim My_Data As Variant
    Dim My_Split_Data As Variant
    Dim Row_Array As Variant
    Dim Last_Row As Long
    Dim X As Long
    Dim adoStream As Object
    Dim n_My_Data As Variant
    
    Set adoStream = CreateObject("ADODB.Stream")
    
    My_File = ThisWorkbook.Path & "\Deneme1.txt"
  
    adoStream.Charset = "UTF-8"
    adoStream.Open
    adoStream.LoadFromFile My_File
 
    n_My_Data = Split(adoStream.ReadText, vbCrLf)

    Row_Array = Array(5, 6, 11, 19, 22)
      
    Range("A2").Resize(Rows.Count - 1, Columns.Count).ClearContents
    
    Last_Row = 2
    
    For X = LBound(Row_Array) To UBound(Row_Array)
        My_Split_Data = Split(n_My_Data(Row_Array(X) - 1), vbTab)
        Cells(Last_Row, 1).Resize(1, UBound(My_Split_Data)) = Split(n_My_Data(Row_Array(X) - 1), vbTab)
        Last_Row = Last_Row + 1
    Next
    
    Columns.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Tevfik_Kursun · 15 Mayıs 2023

Sayın Haluk Hocam, Sayın Korhan Ayhan Hocam, Sayın Dost Hocam, Sayın Veysel Emre Hocam,
Ellerinize sağlık, ilgilerinize çok teşekkür ederim. Çok makbule geçti. Harikasınız.
Affınıza sığınarak, yeri geldiği için sorayım Array(5, 6, 11, 19, 22) ifadesinde parantez içindeki satır numaraları, X4 ten itibaren aşağıya doğru sıralanmış olsa txt dosyasından alınanlar Y4 ten itibaren gelmaz mi?
Saygılarımla

Tevfik_Kursun · 15 Mayıs 2023

Merhaba Arkadaşlar,
Array(5, 6, 11, 19, 22) ifadesindeki satır sayılarını 5, 6, 11, 19, 22 şeklinde V1 hücresindan aldığında "5, 6, 11, 19, 22" şeklinde alıyor ve resimlerdeki hatayı veriyor. Yardımcı olursanız sevinirim.
Saygılarımla

Korhan Ayhan · 16 Mayıs 2023

Deneyiniz.

C++:

Option Explicit

Sub Read_Txt_File()
    Dim My_File As String
    Dim My_Data As Variant
    Dim My_Split_Data As Variant
    Dim Row_No As Variant
    Dim Last_Row As Long

    Range("Y4").Resize(Rows.Count - 3, Columns.Count - 24).ClearContents
   
    If WorksheetFunction.Count(Range("X4:X" & Rows.Count)) = 0 Then
        MsgBox "İşleme devam edebilmeniz için satır numarası girmelisiniz!", vbCritical
        Exit Sub
    End If
   
    My_File = ThisWorkbook.Path & "\Deneme1.txt"
   
    With CreateObject("AdoDB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile My_File
         My_Data = Split(.ReadText, vbNewLine)
    End With
   
    Last_Row = 4
   
    For Each Row_No In Range("X4:X" & Cells(Rows.Count, "X").End(3).Row)
        On Error Resume Next
        My_Split_Data = Empty
        My_Split_Data = Split(My_Data(Row_No - 1), vbTab)
        If Err.Number = 9 Then GoTo 10
        Cells(Last_Row, "Y").Resize(1, UBound(My_Split_Data)) = Split(My_Data(Row_No - 1), vbTab)
10      On Error GoTo 0
        Last_Row = Last_Row + 1
    Next
   
    Columns.AutoFit
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Tevfik_Kursun · 16 Mayıs 2023

Günaydın Korhan Ayhan Hocam,
Gerçek txt dosyasında 320.000 den fazla satır var. 4. mesajdaki makro hızlı çalışıyor. Oradaki sorun .Charset = "UTF-8" ve sütundan okuyamama.
My_Data = Split(.ReadText, vbNewLine) bu satırda tüm dosyayı okuyup düzeltiyor sanırım. Ama çok uzun sürüyor. Aynı bekleme 5. mesajdaki makroda da var. Tüm dosyayı okuyacağına bulduğuna uygulasa daha kısa sürer sanırım.
Saygılarımla

Korhan Ayhan · 16 Mayıs 2023

Haluk beyin önerisindeki hız durumu nedir?

Eğer kodun performansı iyi ise orada gerekli düzenleme yapılabilir.

Tevfik_Kursun · 16 Mayıs 2023

Sayın Korhan Ayhan Hocam,
Şimdi gördüm kusura bakmayın lütfen. Array( ,,,, ) verdiğinizde çok iyi, hemen geliyor. Ama sütundan aldıramadım, V1 den aldıramadım.
(Sanırım sistem artık mesaj atmıyor)
Saygılarımla

Korhan Ayhan · 16 Mayıs 2023

Deneyiniz.

C++:

Option Explicit

Sub Read_Txt_File()
    Dim My_File As String
    Dim My_Data As Variant
    Dim My_Split_Data As Variant
    Dim Row_Array As Variant
    Dim Last_Row As Long
    Dim X As Long

    Range("A2").Resize(Rows.Count - 1, Columns.Count).ClearContents
        
    If Range("V1") = "" Then
        MsgBox "İşleme devam edebilmeniz için V1 hücresine aralarına virgül ekleyerek satır numarası girmelisiniz!", vbCritical
        Range("V1").Select
        Exit Sub
    End If
    
    Row_Array = Split(Range("V1"), ",")
    
    My_File = ThisWorkbook.Path & "\Deneme1.txt"

    My_Data = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(My_File, 1).ReadAll, vbNewLine)
    
    Last_Row = 2
    
    For X = LBound(Row_Array) To UBound(Row_Array)
        If IsNumeric(Row_Array(X)) Then
            On Error Resume Next
            My_Split_Data = Empty
            My_Split_Data = Split(My_Data(Row_Array(X) - 1), vbTab)
            If Err.Number = 9 Then GoTo 10
            Cells(Last_Row, 1).Resize(1, UBound(My_Split_Data)) = Split(My_Data(Row_Array(X) - 1), vbTab)
10          On Error GoTo 0
            Last_Row = Last_Row + 1
        End If
    Next
    
    Columns.AutoFit
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Tevfik_Kursun · 16 Mayıs 2023

Sayın Korhan Ayhan Hocam,
Şimdi gördüm kusura bakmayın lütfen. Makro uygun sürede çalıştı ama Türkçeleştiremedi. Son sütunun verileri de gelmiyor. (Sitenin mail sistemi artık mesaj atmıyor)
Saygılarımla

dost · 16 Mayıs 2023

Merhaba,

@Haluk'un kodları işinizi görür. Hem Türkçe karakterlerde sorun yok, hem de hızlı.
UTF-8'ye çevirmeyi de sadece istediğiniz satırları yapıyor.

Sadece yazmış olduğu kodlarda;

C++:

arrLines = Array(5, 6, 11, 19, 22)

satırını

C++:

If Range("V1") = "" Then
        MsgBox "İşleme devam edebilmeniz için V1 hücresine aralarına virgül ekleyerek satır numarası girmelisiniz!", vbCritical
        Range("V1").Select
        Exit Sub
End If
   
arrLines = Split(Range("V1"), ",")

olarak değiştirin.

Tevfik_Kursun · 16 Mayıs 2023

Merhaba Sayın Dost,
Daha önce de denemiştim.
Saygılarımla

dost · 16 Mayıs 2023

Merhaba,

C++:

Dim arrLines() As Variant

Range("A1:BV" & Rows.Count) = ""

yerine

C++:

Dim arrLines As Variant

Range("A2:BV" & Rows.Count) = ""

Tevfik_Kursun · 16 Mayıs 2023

Merhaba,
Range("A2:BV" & Rows.Count) = ""
bu ifade A2:BV10000 alanını temizliyor. Silmenin dışında bir görevi yok. Temiz zaten o bölge.
Saygılarımla

Haluk · 16 Mayıs 2023

Tevfik_Kursun' Alıntı:
Merhaba,
Range("A2:BV" & Rows.Count) = ""
bu ifade A2:BV10000 alanını temizliyor. Silmenin dışında bir görevi yok. Temiz zaten o bölge.
Saygılarımla

Onun üstündeki satırda belirtilen değişikliği de yapmanız gerekiyor......

Uzun lafın kısası;

C#:

Sub Test3()
    'Haluk - 15/05/2023
    '
    Dim MyPath As String, MyFile As String, strData As String
    Dim objStream As Object
    Dim arrLines As Variant, myArr() As String, myArr2() As String
    Dim LineNo As Long, lngRow As Variant, j As Long
    
    MyPath = ThisWorkbook.Path & "\"
    MyFile = "Deneme1.txt"
    
    Range("A2:BV" & Rows.Count) = ""
    arrLines = Split(Range("V1"), ",")
    
    Set objStream = CreateObject("ADODB.Stream")
    
    objStream.Charset = "UTF-8"
    objStream.Open
    objStream.LoadFromFile MyPath & MyFile
    strData = objStream.ReadText()
    
    LineNo = 1
    myArr = Split(strData, vbCrLf)

    For Each lngRow In arrLines
        LineNo = LineNo + 1
        
        myArr2 = Split(myArr(lngRow - 1), vbTab)
        
        For j = LBound(myArr2) To UBound(myArr2)
            Cells(LineNo, j + 1) = myArr2(j)
        Next
    Next
End Sub

.

dost · 16 Mayıs 2023

Sayın @Haluk,

Ben ne güzel sizin kodu pazarlıyordum

İşi bozdunuz.
Satır sayısı fazla olunca objStream.ReadText() çok yavaşlatıyor.

Bu nedenle sizin yazmış olduğunuz aşağıdaki kod gayet verimli.

NOT: Sadece V1 hücresine yazılan değerlerden birisi txt dosyasının satır sayısından fazla ise hata döndürür. Döngüye girmeden txt dosyanın satır sayısını nasıl buluruz?

C++:

Sub Test4()
    'Haluk - 15/05/2023
    '
    Dim MyPath As String, MyFile As String, strData As String
    Dim myArr() As String, myArr2() As String
    Dim LineNo As Long, lngRow As Variant, j As Long
    Dim arrLines As Variant
    
    MyPath = ThisWorkbook.Path & "\"
    MyFile = "Deneme1.txt"
    
    Range("A2:BV" & Rows.Count) = ""
    arrLines = Split(Range("V1"), ",")
    
    Open MyPath & MyFile For Input As #1
        strData = Input(LOF(1), #1)
    Close #1
    
    LineNo = 1
    
    For Each lngRow In arrLines
        LineNo = LineNo + 1
        
        myArr = Split(strData, vbCrLf)
        myArr2 = Split(myArr(lngRow - 1), vbTab)
        
        For j = LBound(myArr2) To UBound(myArr2)
            Cells(LineNo, j + 1) = Utf8ToUnicode(myArr2(j))
        Next
    Next
End Sub
'
Function Utf8ToUnicode(strText As String) As String
'   Haluk - 28/04/2020
'
    Dim objStream As Object, strRetVal As String
    
    Const adTypeText = 2
    Const adReadAll = -1
    
    Set objStream = CreateObject("ADODB.Stream")
    
    objStream.Open
    objStream.Charset = "Windows-1254"
    objStream.WriteText strText
    objStream.Position = 0
    objStream.Type = adTypeText
    objStream.Charset = "UTF-8"
    strRetVal = objStream.ReadText()
    objStream.Close
    
    Utf8ToUnicode = strRetVal
    Set objStream = Nothing
End Function

Tevfik_Kursun · 16 Mayıs 2023

Merhaba Sayın Haluk Hocam,
Dim ile başlayan ifade zaten makroda hazır olarak var.
Şu anda strData = objStream.ReadText() bu satırda okuma devam ediyor. daha önce böyle bir şey yoktu.
Saygılarımla

Text dosyadan sırası belli satırları çekme

Tevfik_Kursun

Ekli dosyalar

Haluk

Özel Üye

Erdem Akdemir

Destek Ekibi

Korhan Ayhan

Administrator

dost

Tevfik_Kursun

Tevfik_Kursun

Ekli dosyalar

Korhan Ayhan

Administrator

Tevfik_Kursun

Korhan Ayhan

Administrator

Tevfik_Kursun

Korhan Ayhan

Administrator

Tevfik_Kursun

dost

Tevfik_Kursun

Ekli dosyalar

dost

Tevfik_Kursun

Haluk

Özel Üye

dost

Tevfik_Kursun