记事本文件里面数据调成有规律的行数

FRANKEXCELVB

请教老师，我想把记事本文件里面的数据都调成有规律的行数，可以实现吗？特别是 （DETAILED DESCRIPTION 產品內容:  &  COLOR DESCRIPTION 產品顏色明細:   ） 这2个字段后面的数据，他们有时会是两行、多行的，有时是一行的，我想要它们不管多长，每个字段数据都在单独一行，vba 可以实现吗？ 有原始数据，文件名（请教），有需要改后的，文件名（请教-要变成这样）；
不是所有的字段都这样，比如最后一个字段，就是正常的数据，不需要调整；

因为数据太多了， 人工修改，太麻烦了，求教老师指点。

FRANKEXCELVB

不好意思，附件贴上。

未忘初心

1. Sub Main()
   
2.     'Date:2019/2/27 正月廿三 Wednesday
   
3.     '标签:读文本,乱码,写文本,txt文本文件
   
4.     '备注1:http://www.cnblogs.com/waver/articles/1283842.html
   
5.     '备注2:http://club.excelhome.net/thread-1113262-1-1.html
   
6.     Dim temptext As String, textarr, arr, i As Long, k As Long
   
7.     Dim brr, j As Long, 你的文件路径 As String, 生成文本路径 As String
   
8.     你的文件路径 = "C:\Users\Administrator\Desktop\请教.Txt"
   
9.     生成文本路径 = "C:\Users\Administrator\Desktop\想要的文本.txt"
   
10.     temptext = ReadUTF(你的文件路径)
    
11.     textarr = Split(temptext, vbCrLf)
    
12.     ReDim arr(UBound(textarr))
    
13.     For i = 0 To UBound(textarr)
    
14.         If InStr(textarr(i), "產品內容") > 0 Then
    
15.             arr(k) = textarr(i)
    
16.             For Each brr In Array("產品顏色明細", "印刷在外箱上的颜色")
    
17.                 For j = i + 1 To UBound(textarr)
    
18.                     If InStr(textarr(j), brr) > 0 Then
    
19.                         k = k + 1
    
20.                         arr(k) = textarr(j)
    
21.                         Exit For
    
22.                     Else
    
23.                         arr(k) = arr(k) & Trim(textarr(j))
    
24.                     End If
    
25.                 Next
    
26.                 i = j
    
27.             Next
    
28.             k = k + 1
    
29.         Else
    
30.             arr(k) = textarr(i)
    
31.             k = k + 1
    
32.         End If
    
33.     Next
    
34.     Call SaveFile(生成文本路径, Join(arr, vbCrLf))
    
35.     MsgBox "完成"
    
36. End Sub
    
37. Function ReadUTF(ByVal FileName As String) As String
    
38.     With CreateObject("ADODB.Stream")
    
39.         .Type = 2
    
40.         .Mode = 3
    
41.         .Open
    
42.         .LoadFromFile FileName
    
43.         .Charset = "UTF-8"
    
44.         .Position = 2
    
45.         ReadUTF = .ReadText
    
46.         .Close
    
47.     End With
    
48. End Function
    
49. 
    
50. 
    
51. Public Function SaveFile(FileName As Variant, strFileBody As Variant) As Boolean
    
52.     Dim ADO_Stream As Object
    
53.     Set ADO_Stream = CreateObject("ADODB.Stream")
    
54.    
    
55. 
    
56.     With ADO_Stream
    
57.         .Type = 2
    
58.         .Mode = 3
    
59.         .Charset = "utf-8"
    
60.         .Open
    
61.         .WriteText strFileBody
    
62.         .SaveToFile FileName, 2
    
63.     End With
    
64.    
    
65.     SaveFile = True
    
66.     Set ADO_Stream = Nothing
    
67. End Function

复制代码

FRANKEXCELVB

未忘初心 发表于 2019-2-27 19:34

老师，帮我做个含代码的EXCEL文档可以吗？本人太笨，复制到文档里面运行不了。

FRANKEXCELVB

未忘初心 发表于 2019-2-27 19:34

未忘初心老师，正如昨天的问题，因为“DETAILED DESCRIPTION 產品內容:”，“COLOR DESCRIPTION 產品顏色明細:”， 这2个字段，有一部分，不是全部，货号后面数据不在同一行，导致没法将数据顺利提取出来，现在为了提取只能人工找出不规则行，进行手动调整，调整好后才能运行VBA进行提取数据。  

昨天您帮忙写了段代码，但是本人水平有限，代码粘贴进来运行不了，老师能帮忙把代码做到表格里面吗？想在数据提取前运行下老师的代码，把部分不规则货号的数据调成有规律的（“DETAILED DESCRIPTION 產品內容:”，“COLOR DESCRIPTION 產品顏色明細:”）-这2个字段，每个字段单独成一行。

未忘初心

FRANKEXCELVB 发表于 2019-2-28 08:17
未忘初心老师，正如昨天的问题，因为“DETAILED DESCRIPTION 產品內容:”，“COLOR DESCRIPTION 產品顏色 ...

你粘贴到excel  修改
你的文件路径 = "C:\Users\Administrator\Desktop\请教.Txt"
生成文本路径 = "C:\Users\Administrator\Desktop\想要的文本.txt"
这2个地方

FRANKEXCELVB

未忘初心 发表于 2019-2-28 08:27
你粘贴到excel  修改
你的文件路径 = "C:%users\Administrator\Desktop\请教.Txt"
生成文本路径 = "C:% ...

谢谢老师指点，非常感激，帮了我大忙。

FRANKEXCELVB

未忘初心 发表于 2019-2-27 19:34

老师，非常好用，您有空能帮注解下代码就好了，便于我这样的菜鸟学习，万分感激。

FRANKEXCELVB

未忘初心 发表于 2019-2-27 19:34

未忘初心老师，为什么导出的TXT文档开头有1个空格，导致第一个货号的厂号，起始会空一格。

FRANKEXCELVB

未忘初心 发表于 2019-2-27 19:34

老师，您好！能帮忙把您的原来程序加上,   单个处理TXT  /   所有TXT文件一起处理 (去掉不规则行) 的功能吗? 最后的生成的文本就是在原文件名后加  "- 调整"   字符. 谢谢您.   本人太笨, 实在不会改了.

Sub Main()
    'Date:2019/2/27 正月廿三 Wednesday
    '标签:读文本,乱码,写文本,txt文本文件，去掉货描,颜色里面的不规则断行
    Dim temptext As String, textarr, arr, i As Long, k As Long
    Dim brr, j As Long, 你的文件路径 As String, 生成文本路径 As String

    Dim filename(), fileopen, ii
    If MsgBox("处理全部文件？", vbYesNo, "提示") = vbNo Then '单个
    fileopen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "选取文件")
    If fileopen = False Then Exit Sub
    If LCase(Right(fileopen, Len("_cn.txt"))) <> "_cn.txt" Then MsgBox "_cn.txt文件！": Exit Sub
    ReDim filename(1 To 1): filename(1) = fileopen
  Else '全部
    If Not getfilename(filename, ThisWorkbook.path, "_cn.txt") Then MsgBox "文件！": Exit Sub
  End If

     For ii = 1 To UBound(filename)
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Open
      .LoadFromFile filename(ii)
      .Charset = "UTF-8"
      .Position = 5

      .Close
    End With
        Next

    temptext = fileopen
    textarr = Split(temptext, vbCrLf)
    ReDim arr(UBound(textarr))
    For i = 0 To UBound(textarr)
        If InStr(textarr(i), "產品內容") > 0 Then
            arr(k) = textarr(i)
            For Each brr In Array("產品顏色明細", "印刷在外箱上的颜色")
                For j = i + 1 To UBound(textarr)
                    If InStr(textarr(j), brr) > 0 Then
                        k = k + 1
                        arr(k) = textarr(j)
                        Exit For
                    Else
                        arr(k) = arr(k) & Trim(textarr(j))
                    End If
                Next
                i = j
            Next
            k = k + 1
        Else
            arr(k) = textarr(i)
            k = k + 1
        End If
    Next

    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Charset = "utf-8"
      .Open
      .WriteText Join(arr, vbCrLf)
      .SaveToFile Left(filename(ii), Len(filename(ii)) - 4) & "-输出.txt", 2
      .flush
      .Close
    End With


    MsgBox "完成"
End Sub
Function ReadUTF(ByRef filename() As String) As String
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Open
        .LoadFromFile filename(ii)
        .Charset = "UTF-8"
        .Position = 5
        ReadUTF = .ReadText
        .Close
    End With
End Function

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function