• DİKKAT

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

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

T

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,903
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
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
 

Ekli dosyalar

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' 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


.
Genişletmek için tıkla ...

Haluk bey elinize sağlık.
 
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
 
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
 
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
 
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
 

Ekli dosyalar

  • Adsız5.png
    Adsız5.png
    15.8 KB · Görüntüleme: 4
  • Adsız6.png
    Adsız6.png
    5.9 KB · Görüntüleme: 4
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
 
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
 
Haluk beyin önerisindeki hız durumu nedir?

Eğer kodun performansı iyi ise orada gerekli düzenleme yapılabilir.
 
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
 
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
 
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
 
Son düzenleme:
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.
 
Merhaba Sayın Dost,
Daha önce de denemiştim.
Saygılarımla
 

Ekli dosyalar

  • Adsız7.png
    Adsız7.png
    15.7 KB · Görüntüleme: 4
  • Adsız8.png
    Adsız8.png
    5.9 KB · Görüntüleme: 4
Merhaba,

C++: 
Dim arrLines() As Variant

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

yerine

C++: 
Dim arrLines As Variant

Range("A2:BV" & Rows.Count) = ""
 
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
 
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
Genişletmek için tıkla ...

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

.
 
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
 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst