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

assenucler

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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.
 

Ekli dosyalar

Tevfik_Kursun

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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,247
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

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

ÖmerBey

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2012
Mesajlar
4,338
Excel Vers. ve Dili
2007 Türkçe
Merhaba,
Aşağıdaki kodları deneyiniz, sanırım isteğinizi birazcık karşılar. Açılan pencereden text dosyasını seçiniz.
Kod:
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

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,349
Excel Vers. ve Dili
Office 365 (64 bit) - Türkçe
Aşağıdaki prosedur işinizi tam olarak yapacaktır...

PHP:
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

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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.
 

Ekli dosyalar

Son düzenleme:

assenucler

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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

Uzman
Uzman
Katılım
31 Aralık 2005
Mesajlar
4,349
Excel Vers. ve Dili
Office 365 (64 bit) - Türkçe
Elbette sığdırabilirsiniz Selim Bey. Mesaj sütununu "Metni Kaydır" özelliği verin. Ekli resimde ben sığdırdım.
1538689497371.png
 
Son düzenleme:

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.
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.
.
Rich (BB code):
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
 
Son düzenleme:

assenucler

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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.
 
Son düzenleme:

assenucler

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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.
 

Ekli dosyalar

Son düzenleme:

Tevfik_Kursun

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

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
Rica ederim Tevfik Kursun.
 

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.
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

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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.
 

Ekli dosyalar

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.
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

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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

Altın Üye
Katılım
19 Ağustos 2004
Mesajlar
3,552
Excel Vers. ve Dili
Ofis 365 TR 64 Windows 11 Home Single Language x64 TR
Altın Üyelik Bitiş Tarihi
29-05-2025
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ü?
 
Son düzenleme:

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
12,997
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Altın Üyelik Bitiş Tarihi
(18.03.2020) - Uzman olduğu için tarih geçersiz oldu.
Belge ekte.
Belgede Sayfa1 ve Sayfa2 dışında ad taşıyan sayfalar işlem öncesi silinir (veri kaybetmeyin sakın)
.
 

Ekli dosyalar

Üst