txt olusturma

Rainbows · 6 Haziran 2021

Selamlar,

ekteki dosyamda h5 kolonuna göre göre txt dosyasına aktarmak istiyorum.

yapmak istedigim şöyle birşey h5 kolunundaki aynı olan her kod için bir header oluşturmak( h1,h2,h4,h4,h5 sabit) detail kısımları bu 5 kolon alt birimi olarak tek tek oluşturulması.

örnek dosyamı ekte iletiyorum.

yapmak istedigim txt formatı aşagıdaki gibidir. örnek excel dosyamdaki ilk 4 kolunu ben manuel olarak yaptım. orjial dosyamdaki kolon sayısı cok fazla bunu el ile yapmam imkansız.

<Header>
<h1>ankara</h1>
<h2>01.01.2021</h2>
<h3>10020020</h3>
<h4>hhhh4</h4>
<h5>100</h5>
<Detail>
<d1>120</d1>
<d2>detay211</d2>
<d3>detay211</d3>
<d4>120010000</d4>
<d5>101.1</d5>
<d6>a</d6>
<d7>ınv</d7>
<d8></>
<d9>202000000</d9>
<d10>01.12.2020</d10>
<d11>ödeme</d11>
<d12>mcg 120d</d12>
</Detail>
<Detail>
<d1>600</d1>
<d2>detay211</d2>
<d3>detay211</d3>
<d4>600010000</d4>
<d5>104.3</d5>
<d6>a</d6>
<d7>ınv</d7>
<d8></>
<d9>202000000</d9>
<d10>01.12.2020</d10>
<d11>ödeme</d11>
<d12>mcg 120d</d12>
</Detail>
</Detail>
</Header>
<Header>
<h1>istanbul</h1>
<h2>01.01.2021</h2>
<h3>10020021</h3>
<h4>hhhh4</h4>
<h5>101</h5>
<Detail>
<d1>611</d1>
<d2>detay213</d2>
<d3>detay213</d3>
<d4>611010000</d4>
<d5>105</d5>
<d6>a</d6>
<d7>ınv</d7>
<d8></>
<d9>202000000</d9>
<d10>01.12.2020</d10>
<d11>ödeme</d11>
<d12>mcg 120d</d12>
</Detail>
<Detail>
<d1>391</d1>
<d2>detay214</d2>
<d3>detay214</d3>
<d4>391010000</d4>
<d5>106</d5>
<d6>a</d6>
<d7>ınv</d7>
<d8></>
<d9>202000000</d9>
<d10>01.12.2020</d10>
<d11>ödeme</d11>
<d12>mcg 120d</d12>
</Detail>
</Header>

Zeki Gürsoy · 7 Haziran 2021

d8 isimli tag'da yazım yanlışı var. Öyle olması gerektiğine emin misiniz?

Rainbows · 7 Haziran 2021

Zeki Gürsoy' Alıntı:
d8 isimli tag'da yazım yanlışı var. Öyle olması gerektiğine emin misiniz?

d8 kolonu boş satır.

Rainbows · 7 Haziran 2021

Zeki Gürsoy' Alıntı:
d8 isimli tag'da yazım yanlışı var. Öyle olması gerektiğine emin misiniz?

dediginiz dogru kapama kodu eksik kalmıs. aşagıdaki gibi olması gerekiyor.

<d8></d8>

veyselemre · 7 Haziran 2021

Kod:

Sub textFile()

    Dim fso As Object, f As Object
    Dim dosya$, metin$
    Dim hKeyTemp$, hKey$

    dosya = "c:\users\pc\desktop\rainbows.txt"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.CreateTextFile(dosya, True)

    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        hKey = Join(Application.Index(Cells(i, 1).Resize(1, 4).Value, 0), "|")
        If hKey <> hKeyTemp Then
            If hKeyTemp <> "" Then f.writeline "</Header>"
            f.writeline "<Header>"
            For ii = 1 To 5
                metin = "<h" & ii & ">" & Cells(i, ii).Value & "</h" & ii & ">"
                f.writeline metin
            Next ii
            hKeyTemp = hKey
        End If
        f.writeline "<Detail>"
        For ii = 6 To 17
            metin = "<d" & ii - 5 & ">" & Cells(i, ii).Value & "</d" & ii - 5 & ">"
            f.writeline metin
        Next ii
        f.writeline "</Detail>"
    Next i
    f.writeline "</Header>"
    f.Close
    
End Sub

Rainbows · 7 Haziran 2021

veyselemre' Alıntı:

Kod:

Sub textFile()

    Dim fso As Object, f As Object
    Dim dosya$, metin$
    Dim hKeyTemp$, hKey$

    dosya = "c:\users\pc\desktop\rainbows.txt"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set f = fso.CreateTextFile(dosya, True)

    For i = 2 To Cells(Rows.Count, 1).End(3).Row
        hKey = Join(Application.Index(Cells(i, 1).Resize(1, 4).Value, 0), "|")
        If hKey <> hKeyTemp Then
            If hKeyTemp <> "" Then f.writeline "</Header>"
            f.writeline "<Header>"
            For ii = 1 To 5
                metin = "<h" & ii & ">" & Cells(i, ii).Value & "</h" & ii & ">"
                f.writeline metin
            Next ii
            hKeyTemp = hKey
        End If
        f.writeline "<Detail>"
        For ii = 6 To 17
            metin = "<d" & ii - 5 & ">" & Cells(i, ii).Value & "</d" & ii - 5 & ">"
            f.writeline metin
        Next ii
        f.writeline "</Detail>"
    Next i
    f.writeline "</Header>"
    f.Close
   
End Sub

Selamlar,

ilginiz için teşekkürler,

orjinal dosyam yaklaşık 25.000 satırlı sizin makronuz calışıyor fakat aşagıdaki gibi hata almaktayım.

veyselemre · 7 Haziran 2021

Kodla ilgili bir sorun değildir. Yazmaya çalışılan veri ile ilgili bir sorun vardır. Hata verdiği zaman sarıyla işaretlediğiniz kısımda fareyi metin değişkenin üzerinde tutun aldığı değeri inceleyin.

Zeki Gürsoy · 8 Haziran 2021

Oluşturmaya çalıştığınız XML/HTML biçimi kurallara uymadığından ve parser'lar tarafından okunamadığından "root" isminde bir kök düğüm eklenmesi gerekliydi...

Eğer gerekli değilse ilk satırdaki xml deklarasyonu ile, baştaki <root> ve en sondaki </root> tag'larını notepad ile açarak silebilirsiniz.

Dosya ve ekran görüntüsü ektedir.

Tarayıcı görüntüsü:

Notepad görüntüsü:

C#:

Sub test()
    Dim doc As New DOMDocument60, header As IXMLDOMElement, detail As IXMLDOMElement, root As IXMLDOMElement, el As IXMLDOMElement
    Dim i As Integer, lastRow As Long, lRow As Long, curH5 As String
   
    Set root = doc.createElement("root")
    doc.appendChild root
   
    With Worksheets("Sheet1")
       
        lastRow = .Cells(Rows.Count, "a").End(3).Row
       
        If lastRow = 1 Then GoTo ExitProc
       
        For lRow = 2 To lastRow
           
            If curH5 = "" Or curH5 <> .Cells(lRow, "h") Then
                curH5 = .Cells(lRow, "h")
               
                Set header = doc.createElement("Header")
                root.appendChild header
   
                For i = 1 To 5
                    Set el = doc.createElement("h" & i)
                    el.Text = .Cells(lRow, i)
                    header.appendChild el
                Next
               
            End If
           
            Set detail = doc.createElement("Detail")
            header.appendChild detail
           
            For i = 1 To 12
                Set el = doc.createElement("d" & i)
                el.Text = IIf(i = 5, Replace(.Cells(lRow, i + 5), ",", ".", Count:=1), .Cells(lRow, i + 5))
                detail.appendChild el
            Next
           
        Next
       
    End With
   
    Call AddIndent(doc.XML, Environ("UserProfile") & "\Desktop\LOG.xml")
   
    MsgBox "Dosya, '" & Environ("UserProfile") & "\Desktop\LOG.xml' ismiyle kaydedildi.", vbInformation
    Exit Sub
ExitProc:
    MsgBox "Listede kayıt yok.", vbExclamation
End Sub

Private Function AddIndent(ByVal objDocOrXml, Optional ByVal destFileName As String) As String
    'Zeki'
    '
    Dim doc As New DOMDocument60, rdr As New SAXXMLReader60, wrt As New MXXMLWriter60, reg As New RegExp, strXML As String
   
    If IsObject(objDocOrXml) Then
        doc.Load objDocOrXml
    Else
        doc.LoadXML objDocOrXml
    End If
   
    wrt.indent = True
    wrt.omitXMLDeclaration = True
    wrt.byteOrderMark = False
    wrt.Encoding = "utf-8"
   
    Set rdr.contentHandler = wrt

    rdr.Parse doc
    doc.LoadXML wrt.output
   
    reg.Global = True
    reg.Pattern = "\<(\w+)\/>"
   
    strXML = reg.Replace(doc.XML, "<$1></$1>")
   
    doc.LoadXML strXML
    doc.InsertBefore doc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'"), doc.DocumentElement
   
    If destFileName <> "" Then doc.Save destFileName
   
    AddIndent = doc.XML
End Function

txt olusturma

Rainbows

Ekli dosyalar

Zeki Gürsoy

Uzman

Rainbows

Rainbows

veyselemre

Özel Üye

Rainbows

Ekli dosyalar

veyselemre

Özel Üye

Zeki Gürsoy

Uzman

Ekli dosyalar