Çözüldü Txt dosyasını Excel'e aktarma?

[assenucler]

Değerli Dostlar;

Ekteki metin dosyası "Tarih, Saat, Mesaj Yollayan, Mesaj İçeriği" başlıkları altında excel'e nasıl aktarılabilir?
4 Sütunlardaki satırların karakter sayısı, 15 - 1500 arasında değişmektedir.

Yardımınızı rica ediyorum.

 

[Tevfik_Kursun]

Merhaba Arkadaşım,
.txt dosyanız düzgün değil. Bazı e-postalar parçalanmış. Bana göre zor, ama bilemem uzmanlar bakarsa belki çözüm bulunur.
Kolay gelsin

 

[Korhan Ayhan]

Merhaba,

Verilerinizi ayıran belirgin bir sembol yok. Bu sebeple çözüm üretecek arkadaşları biraz uğraştırabilir.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodları deneyiniz, sanırım isteğinizi birazcık karşılar. Açılan pencereden text dosyasını seçiniz.

Sub Makro1()
dosya = Application.GetOpenFilename(FileFilter:="Text dosyaları(*.txt),(*txt)", Title:="Dosyadan veri al")
If dosya = False Then Exit Sub
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & dosya, Destination:= _
        Range("$A$1"))
        .Name = "Sor_TXT_TemsKurulu sohbeti"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Call Makro2
End Sub
Private Sub Makro2()
For a = 1 To Range("A65500").End(3).Row
    If Cells(a, "A") = "" Then GoTo sonraki
    If IsDate(Split(Cells(a, "A"), " - ")(0)) Then
        metin = Cells(a, "A")
    Else
        metin = metin & " " & Cells(a, "A")
    End If
  
    If Cells(a + 1, "A") = "" Then GoTo sonraki
    If IsDate(Split(Cells(a + 1, "A"), " - ")(0)) Then
        ayr1 = InStr(1, metin, " - ")
        met1 = Split(metin, " - ")(0)
        met2 = Mid(metin, ayr1 + 3, Len(metin))
        ayr2 = InStr(met2, ":")
        Cells(a, "B") = Left(met1, Len(met1) - 6)
        Cells(a, "C") = Right(met1, 5)
        Cells(a, "D") = Left(met2, ayr2 - 1)
        Cells(a, "E") = Mid(met2, ayr2 + 1, Len(met2))
        metin = ""
    End If
sonraki:
Next
End Sub

 

[Zeki Gürsoy]

Aşağıdaki prosedur işinizi tam olarak yapacaktır...

Sub Test()
    fname = Application.GetOpenFilename("Text dosyaları(*.txt),(*txt)")
    If fname = False Then Exit Sub
    
    txt = CharsetFromStringToTR(GetTxt(fname))
    
    Set regex = CreateObject("VBScript.RegExp")
    
    regex.Global = True
    regex.IgnoreCase = True
    regex.MultiLine = True
    regex.Pattern = "(\d{1,2}\.\d{1,2}\.\d{4})\s(\d{2}:\d{2})\s-\s(\w+\s\w*):\s"
    
    If regex.Test(txt) = False Then Exit Sub
    
    Set mc = regex.Execute(txt)
    
    For i = 0 To mc.Count - 1
        
        Cells(i + 1, "a") = mc(i).SubMatches(0)
        Cells(i + 1, "b") = mc(i).SubMatches(1)
        Cells(i + 1, "c") = mc(i).SubMatches(2)
        
        txt = Replace(txt, mc(i), vbNewLine)
    Next
    
    arr = Split(txt, vbNewLine)
    
    For i = 1 To UBound(arr)
        
        Cells(i, "d") = arr(i)
        
    Next

End Sub

Private Function GetTxt(ByVal FileName As String) As String
    Open FileName For Input As #1
        GetTxt = Replace(Input(LOF(1), 1), vbLf, "")
    Close
End Function

Private Function CharsetFromStringToTR(ByVal srcString As String, Optional ByVal dstFileName As String = "") As String
    ' Zeki GÜRSOY © 2017
    'Charset özelliğini iki defa kullanıyoruz.
    With CreateObject("ADODB.Stream")
        .Open
        .Charset = "windows-1254" '< Kaynak için charset
        .WriteText srcString
        .Position = 0
        .Charset = "utf-8"        '< Hedef için charset
        If Trim(dstFileName) <> "" Then .SaveToFile dstFileName, 2 'adSaveCreateOverWrite
        CharsetFromStringToTR = .ReadText
        .Close
    End With
End Function

 

[assenucler]

Sayın Tevfik_Kursun,
Sayın Korhan Ayhan,
Sayın Ömer Bey,


Öncelikle ilginiz için teşekkürler.

Hafta sonu apartmanımızın son toplantısı var. Binamız yıkıldı. Telefonun Whatsapp grubunu oluşturan üyelerin birbirlerine yolladığı ve aldığı mesajları, txt formatına çevirdikten sonra, bu konuya ilişkin dosyaları sitemizden incelemeye çalıştım.

Verilere ayıran belirgin semboller olmadığından, 4 gündür uğraşıyorum. Önce txt dosyayı Word dosyasına kopyalayıp, satırlara ayırdım. Daha sonra, Değiştir ile daha anlaşılabilir duruma getirip, Excel "Veriler Metni Sütunlara Dönüştür" ile bir yere geldim.

İlişikteki excel dosyasını yolluyorum. Dosyanın "D" sütununda karakter sayısı, satırlara göre değişmekte, bu sayı 22 - 1500 arasında olunca, bunu A4 yazdırabilmek için ne yapmam gerektiğini karar veremediğim için sitemizde siz değerli üstatlardan yardım almayı düşündüm.

Henüz el atamadığım, yukarıdaki txt dosyasından daha büyük boyutlu bir dosyam daha var. Buradan alacağım destek ile inşallah daha kısa sürede bir çözüme ulaşabilirim.

 

[assenucler]

Sayın Ömer Bey,
Sayın Zeki Gürsoy,


Yukarıdaki mesajımı yazarken, sizlerin çözüme ilişkin yanıtlarınızı görmeden iletiyi yolladığımı fark ettim. Hepinize ayrı ayrı teşekkür ederim.

Sanırım yarın sabah deneyeceğim. Üsteki iletimde değindiğim gibi, bir yazıcıdan çıktı alacağım için 22 - 1500 karaktere ulaşan "D" sütununun A4 kağıda sığdırabilmem mümkün olabilecek mi? Çok merak ediyorum.

Sizlere olumlu, ya da olumsuz dönüş yapacağım.

Sevgi ve saygılar.

 

[Zeki Gürsoy]

Elbette sığdırabilirsiniz Selim Bey. Mesaj sütununu "Metni Kaydır" özelliği verin. Ekli resimde ben sığdırdım.

 

[Ömer BARAN]

Merhabalar.

Bir amatör kod alternatifi de benden olsun.
-- Sayfa1 ve Sayfa2 adlı iki sayfası olan belgede, Sayfa1'in kod bölümüne aşağıdaki kod'u yapıştırın.
-- Txt belge içeriğini kopyalayıp Sayfa1 A2 hücresine yapıştırın,
-- Verdiğim kod'u çalıştırın.
.

Sub ASSENUCLER()
Sheets("Sayfa1").Activate
Application.ScreenUpdating = False
Range("B:D").ClearContents
son = Cells(Rows.Count, 1).End(3).Row
[C1] = "ZAMAN - KİŞİ": [D1] = "MESAJ"
With Range("B2:B" & son)
    .Formula = "=IF(ISNUMBER(LEFT(A2,10)*1),MAX($B$1:B1)+1,B1)"
    .Value = .Value
End With
For sat = 2 To son
        If WorksheetFunction.CountIf(Range("B1:B" & sat), Cells(sat, 2)) = 1 Then
            ikinokta1 = WorksheetFunction.Search(":", Cells(sat, 1), 1)
            If Len(Cells(sat, 1)) > ikinokta1 + 3 Then
                ikinokta2 = WorksheetFunction.Search(":", Cells(sat, 1), ikinokta1 + 1)
            Else: ikinokta2 = ikinokta1 + 2
            End If
           
            Cells(sat, 3) = Mid(Cells(sat, 1), 1, ikinokta2)
        End If
    For satt = sat To sat - 1 + WorksheetFunction.CountIf([B:B], Cells(sat, 2))
        If sat = satt Then
            metin = Replace(Cells(sat, 1), Cells(sat, 3), "")
        Else: metin = metin & " " & Cells(satt, 1)
        End If
    Next
    Cells(sat, 4) = metin: metin = "": sat = satt - 1
Next
    Range("A1:D" & son).AutoFilter Field:=3, Criteria1:="<>"
    Range("C2:D" & son).SpecialCells(xlCellTypeVisible).Copy Sheets("Sayfa2").[B2]
    With Sheets("Sayfa2").Columns("B:B")
        .ColumnWidth = 28: .Font.Size = 8
    End With
    With Sheets("Sayfa2").Columns("C:C")
        .ColumnWidth = 96: .WrapText = True: .Font.Size = 8
    End With
    Sheets("Sayfa2").Columns("B:C").VerticalAlignment = xlTop
    Sheets("Sayfa2").Rows.AutoFit
    Range("A1:D" & son).AutoFilter Field:=3
Range("B2:B" & son).ClearContents: Sheets("Sayfa2").Activate
Sheets("Sayfa1").[C1:D1].Copy Sheets("Sayfa2").[B1]
Sheets("Sayfa1").[B:D].Clear: Sheets("Sayfa1").[1:1].ClearContents
Sheets("Sayfa1").AutoFilterMode = False
Sheets("Sayfa2").PageSetup.PrintArea = "B1:C" & Sheets("Sayfa2").Cells(Rows.Count, 2).End(3).Row
Sheets("Sayfa2").PageSetup.Orientation = xlLandscape
Application.ScreenUpdating = True
10: MsgBox "İşlem Tamam."
End Sub

 

[assenucler]

Sayın Ömer Baran,

Hayırlı Cuma'lar.

Üstadım son çözüm önerisinde bulunan sizden başladım. Bir sorun görmedim. Allah'ım siz ve sizin gibi üstatlarımızı başımızdan eksik etmesin.
Verdiğiniz emek, yardım için çok teşekkür eder, sevgi ve saygılarımı sunarım.

 

[assenucler]

Sayın Zeki Gürsoy,

Hayırlı Cuma'lar.

Üstadım, dosyaya aktarma yaparken çok sayıda ileti mesajları, birbirinin içine geçmekte ve bu durum devamlılık gösterebilmektedir.
Bu durum 8. iletiye eklediğiniz ekran görüntü resminde de görülmektedir.

Size ilk ekran görüntüsünün resmini yolluyorum ve görüleceği gibi, kırmızı ile çevrili alanların satır başı olması gerekiyor.

Bilgilerinizi rica eder hayırlı işler dilerim.

Sevgi ve saygılar.

 

[Tevfik_Kursun]

Sayın Ömer Baran Hocam,
Ben de çok teşekkür ederim. Emin değilim ama sanırım ön ifadeli test sorularını bu makro sayesinde alabilirim.
Size de teşekkür ederim sayın Assenucler arkadaşım, text alma konusunu açtığınız için.
Saygılarımla

 

[assenucler]

Rica ederim Tevfik Kursun.

 

[Ömer BARAN]

Estağfurullah Sayın @Tevfik_Kursun .
Benimkisi halledebilir miyim diye ilgilenip bir deneme yapmaktan ibaret.
Çok profesyonelce olmayabilir ama, verilere bakıp, verilerin yapısını yakalayıp
(istisna varsa ona ilişkin eklemeleri yaparak) sayfaya yazdırmak.
.

 

[assenucler]

Sayın ÖmerBey,


Kısa süredeki çözüm ve paylaşımınız dolayısıyla verdiğiniz, emek için bir kez daha teşekkür ederim. Ekran görüntüsü ilişiktedir.

A4 kağıda sığdırmada sorun yaşanacak gibi görünüyor.

Saygılar.

 

[Ömer BARAN]

Tekrar merhaba.

Çözüm için Sayfa2'yi yatay kullanıp, font ve sütun genişliklerini biraz değiştirdim.
Önceki cevabımdaki kod'u tekrar kontrol edin.

Varsa önce, Sayfa2'deki sayfa yapısı, sütun genişliği gibi şeyleri temizleyin.

Yalnız, txt'yi Sayfa1 A2'ye yapıştırdığınızdan emin olun ve işlem sonucunun da Sayfa2'de alındığını unutmayın.
Kod'da yazdırma alanı/yatay/font ayarları var.
.

 

[assenucler]

Sayın üstadlarımın emeğine bir saygısızlık ve kendilerinin gönül kırgınlığı olacaksa, çok üzülürüm.

Bu durumda, "çözüldü" için biraz daha bekleyeceğim.

 

[assenucler]

Sayın Ömer Baran,

Üstadım, iyi akşamlar, haklarınız nasıl ödenecek bilmiyorum. Yeni kodları deneyip, dönüş yaparım.

Saygılar

 

[assenucler]

Sayın Ömer Baran,

Kişilere ait iletileri ayrı sayfalarda ayrı ayrı listeleyip, toplam ileti sayısı ile birlikte yazdırmak mümkün mü?

 

[Ömer BARAN]

Belge ekte.
Belgede Sayfa1 ve Sayfa2 dışında ad taşıyan sayfalar işlem öncesi silinir (veri kaybetmeyin sakın)
.