可以运行后把数据库里面的中文加到TXT文档里面吗?

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-21 12:58
针对表格中第一行的数据做个输出附件，写上中间空格数。尽量不要用文字表达，也可以上图，，，

要这个样子的,见第一个货号的数据行, 实际上每个货号涉及3个字段要匹配中文.

FRANKEXCELVB

FRANKEXCELVB 发表于 2019-3-21 13:13
要这个样子的,见第一个货号的数据行, 实际上每个货号涉及3个字段要匹配中文.

下面2个字段(产品颜色明细, 包装)的空格数,就是对应的英文结束后,10个空格就行.

一把小刀闯天下

FRANKEXCELVB 发表于 2019-3-21 13:13
要这个样子的,见第一个货号的数据行, 实际上每个货号涉及3个字段要匹配中文.

Option Explicit

Sub test()
  Dim i, j, arr, filename, dic, t, s
  filename = ThisWorkbook.Path & "\147654_CN.txt"
  If Len(Dir(filename)) = 0 Then MsgBox filename: Exit Sub
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  ReDim t(2)
  For i = 1 To UBound(arr, 1)
    If Not dic.exists(arr(i, 1)) Then
      t(0) = arr(i, 2): t(1) = arr(i, 3): t(2) = arr(i, 4)
      dic(arr(i, 1)) = t
    Else
      MsgBox "有重复数据：" & arr(i, 1): Exit Sub
    End If
  Next
  With CreateObject("ADODB.Stream")
    .Type = 2
    .Mode = 3
    .Open
    .LoadFromFile filename
    .Charset = "UTF-8"
    .Position = 2
    arr = Split(Mid(.ReadText, 3), vbNewLine)
    .Close
  End With
  For i = 0 To UBound(arr)
    If IsNumeric(Left(arr(i), 1)) Then
      t = Split(arr(i), Space(1))
      For j = 1 To UBound(t)
        If Len(t(j)) Then
          If dic.exists(t(j)) Then
            s = dic(t(j))
            arr(i + 1) = Space(39) & s(0)
            arr(i + 3) = arr(i + 3) & Space(10) & s(1)
            arr(i + 5) = arr(i + 5) & Space(10) & s(2)
          End If
          i = i + 5: Exit For
        End If
      Next
    End If
  Next
  With CreateObject("ADODB.Stream")
    .Type = 2
    .Mode = 3
    .Charset = "utf-8"
    .Open
    .WriteText Join(arr, vbNewLine)
    .SaveToFile Left(filename, Len(filename) - 4) & "-输出.txt", 2
    .flush
    .Close
  End With
End Sub

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-21 13:32
Option Explicit

Sub test()

太漂亮了!!!

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-21 13:32
Option Explicit

Sub test()

老师, 又出现了新情况, 用147654做可以,换 147652,147656 就不行了, 我已经改输入文件那里了.
运行后,TXT文档的第一个字符还会被删除,乍回事儿呢,原谅我这个小白,净添麻烦了,

另外,数据表格里面不能有重复的字段吗?  您看看附件.

一把小刀闯天下

4楼我已经提醒过你了,不能光复制粘贴还得要看注释，自己试一下，，，

If IsNumeric(Left(arr(i), 1)) Then 改成：
---
If IsNumeric(Left(arr(i), 1))  or left(arr(i),1)>="A" and   left(arr(i),1)<="Z"  Then

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-21 14:24
4楼我已经提醒过你了,不能光复制粘贴还得要看注释，自己试一下，，，

If IsNumeric(Left(arr(i), 1)) T ...

原谅我的粗心,老师您确实注解了,谢谢!

现在每个货号3个中文字段都能加了,但是新生成的TXT文件, 原文里面的第一行,第一个字母会被删掉.

一把小刀闯天下

FRANKEXCELVB 发表于 2019-3-21 14:39
原谅我的粗心,老师您确实注解了,谢谢!

现在每个货号3个中文字段都能加了,但是新生成的TXT文件, 原文里 ...

'换一冲方法，，，

Option Explicit

Sub test()
  Dim i, j, ii, arr, filename(), dic, t, s
  If Not getfilename(filename, ThisWorkbook.Path, "_cn.txt") Then MsgBox "文件！": Exit Sub
  Set dic = CreateObject("scripting.dictionary")
  arr = [a1].CurrentRegion
  ReDim t(2)
  For i = 1 To UBound(arr, 1)
    If Not dic.exists(arr(i, 1)) Then
      t(0) = arr(i, 2): t(1) = arr(i, 3): t(2) = arr(i, 4)
      dic(arr(i, 1)) = t
    Else
      MsgBox "有重复数据：" & arr(i, 1): Exit Sub
    End If
  Next
  For ii = 1 To UBound(filename)
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Open
      .LoadFromFile filename(ii)
      .Charset = "UTF-8"
      .Position = 2
      arr = Split(.ReadText, vbNewLine)
      .Close
    End With
    For i = 0 To UBound(arr) Step 10
      t = Split(arr(i), Space(1))
      For j = 1 To UBound(t)
        If Len(t(j)) Then
          If dic.exists(t(j)) Then
            s = dic(t(j))
            arr(i + 1) = Space(39) & s(0)
            arr(i + 3) = arr(i + 3) & Space(10) & s(1)
            arr(i + 5) = arr(i + 5) & Space(10) & s(2)
          End If
          Exit For
        End If
    Next j, i
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Charset = "utf-8"
      .Open
      .WriteText Join(arr, vbNewLine)
      .SaveToFile Left(filename(ii), Len(filename(ii)) - 4) & "-输出.txt", 2
      .flush
      .Close
    End With
  Next
End Sub

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

一把小刀闯天下

‘楼上换了一种判断方法，每个块假设都是10行，，，’

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-21 14:44
'换一冲方法，，，

Option Explicit

老师,还有个问题,您的查找匹配非常好用,但是实际上我们的原始TXT文档里面有好多不规则行,像XN5875,XN8560等,他们的产品内容/产品颜色明细行是不规则的,我们要先给他整理成正常的行,才能进行后期的中文对照匹配,前些日子有老师给写了一段代码,功能不错,把不规则行都做连续了,但是就是会在生成后的文档第一个字母前会留一个空格,会影响后期查找,匹配,您能给修改修改代码吗,?

Sub Main()
    '标签:读文本,乱码,写文本,txt文本文件，去掉货描,颜色里面的不规则断行
    Dim temptext As String, textarr, arr, i As Long, k As Long
    Dim brr, j As Long, 你的文件路径 As String, 生成文本路径 As String
    你的文件路径 = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Please select text file...")
    On Error Resume Next
    生成文本路径 = Application.GetOpenFilename("Text Files (*.txt),*.txt", , "Please select text file...")
    On Error Resume Next
    temptext = ReadUTF(你的文件路径)
    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
    Call SaveFile(生成文本路径, Join(arr, vbCrLf))
    MsgBox "完成"
End Sub
Function ReadUTF(ByVal filename As String) As String
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Open
        .LoadFromFile filename
        .Charset = "UTF-8"
        .Position = 2
        ReadUTF = .ReadText
        .Close
    End With
End Function


Public Function SaveFile(filename As Variant, strFileBody As Variant) As Boolean
    Dim ADO_Stream As Object
    Set ADO_Stream = CreateObject("ADODB.Stream")


    With ADO_Stream
        .Type = 2
        .Mode = 3
        .Charset = "utf-8"
        .Open
        .WriteText strFileBody
        .SaveToFile filename, 2
    End With

    SaveFile = True
    Set ADO_Stream = Nothing
End Function