谁帮我写个VBA代码啊

rszmyc

0000.rar (3.64 KB, 下载次数: 9)

2017-2-8 21:33 上传

点击文件名下载附件

谁帮我写个VBA代码啊，让execl文件的部分内容转入dat文件（或TXT文件）

duquancai

你就这样提问？神仙也没法帮你！！！

rszmyc

duquancai 发表于 2017-2-8 21:37
你就这样提问？神仙也没法帮你！！！

怎么了，看附件说明

duquancai

rszmyc 发表于 2017-2-8 21:39
怎么了，看附件说明

刚看了，附件说明，并不难但是烦，白帮忙写代码，我没时间，呵呵；你坐等其他人帮你写吧。

rszmyc

duquancai 发表于 2017-2-8 21:47
刚看了，附件说明，并不难但是烦，白帮忙写代码，我没时间，呵呵；你坐等其他人帮你写吧。

牛人啊。。。

zax010

Sub zz()
    ar = [a1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 1 To UBound(ar)
        If ar(i, 2) = "" Then
            s = ar(i, 1): n = 0
        Else
            m = m + 1: br(m, 2) = ar(i, 1): br(m, 3) = ar(i, 2)
            br(m, 1) = Mid(s, 1, 5) & Val(Right(s, 1)) + n: n = n + 1
        End If
    Next
    ReDim cr(1 To m)
    For i = 1 To m
        cr(i) = br(i, 1) & "," & "00000000" & "," & br(i, 2) & "," & br(i, 3) & "," & "0.0"
    Next
    s = Join(cr, Chr(10))
    Open ThisWorkbook.Path & "\" & "文本.dat" For Output As #1
    Print #1, s
    Close #1
End Sub

zax010

结果直接出dat文件，不出现在工作表上。


0000.rar (9.93 KB, 下载次数: 12)

2017-2-9 14:12 上传

点击文件名下载附件

rszmyc

zax010 发表于 2017-2-9 14:13
结果直接出dat文件，不出现在工作表上。

       谢谢老师的帮助，我想再增加一个按钮（如下图），让它能够直接读进TXT文件的数据（保留四位小数），应该怎样实现呢，或者说读入0000.TXT文件，就写入0000.dat文件，再次表示感谢！

rszmyc

谁能帮着解决 8 楼的问题呢

zax010

rszmyc 发表于 2017-2-10 04:48
谢谢老师的帮助，我想再增加一个按钮（如下图），让它能够直接读进TXT文件的数据（保留四位小数） ...

Sub zzz()
    Dim Filename As Variant, myText, mArr() As String
    Dim i As Long, j As Long
    Filename = ThisWorkbook.Path & "\新建文本文档.txt"
    j = 1
    With Sheet1
        .Cells.ClearContents
        Open Filename For Input As #1
        Do While Not EOF(1)
            Line Input #1, myText
            mArr = Split(myText, "     ")
            For i = 0 To UBound(mArr)
             .Cells(j, i + 1) = mArr(i)
            Next i
            j = j + 1
        Loop
        Close #1
    End With
    zz
End Sub

Sub zz()
    ar = [a1].CurrentRegion
    ReDim br(1 To UBound(ar), 1 To 3)
    For i = 1 To UBound(ar)
        If ar(i, 2) = "" Then
            s = ar(i, 1): n = 0
        Else
            m = m + 1: br(m, 2) = ar(i, 1): br(m, 3) = ar(i, 2)
            br(m, 1) = Mid(s, 1, 5) & Val(Right(s, 1)) + n: n = n + 1
        End If
    Next
    ReDim cr(1 To m)
    For i = 1 To m
        cr(i) = br(i, 1) & "," & "00000000" & "," & br(i, 2) & "," & br(i, 3) & "," & "0.0"
    Next
    s = Join(cr, Chr(10))
    Open ThisWorkbook.Path & "\" & "文本.dat" For Output As #1
    Print #1, s
    Close #1
End Sub