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

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-21 14:55
‘楼上换了一种判断方法，每个块假设都是10行，，，’

是的, 老师.  我的目标就是要把每个货号整理成有规律的10行, 来进行后期的操作, 但是原文有时    有2行字段   会是不规则/不规律的,   產品內容/產品顏色明細.  它会是一会或者多行;

刚刚请教您的那段程序运行后会出现TXT文档第一个字母前多一个空格,会影响后期查找,匹配,您帮看看如何改程序.

一把小刀闯天下

没想到你提供的文件并不是源文件。特地看了一下你的utf-8文件编码标志位都有问题，前3位是它的编码标志位（EFBBBF->utf-8编码特征），但你提供的文件2个多了1位1个多了3位，我并不清楚你这文件是从哪里来的，应该是由代码生产的，所以按utf-8读取文件会出问题。

别人写的代码我不会去修改的，可以联系给你写代码的人，因为每个人解决问题的思路一般都不一样。

如果想解决问题尽量不要掐头去尾随便给人一个附件，好了到此为止，，，

--------------

FRANKEXCELVB

明白了，谢谢老师，不同的附件因为是不同的订单文件，我不是有意的，因为有不同的订单文件要处理。

FRANKEXCELVB

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

Option Explicit

小刀老师您好!您的程序非常好用,大大减轻了我的工作量,非常感激您. 这两天我根据自己的实际需要,有些地方进行了改动.


匹配中文的包装那块, 我合计要在表格里面把他们全部都加上,工作量太大, 而且他们都是有规律的,英文包装类型不多, 原来我都是在EXCEL表格里面进行替换,现在合计能不能在TXT里面就进行替换, 并把中文显示在对应的英文后面,可以实现吗? 我自己实在不会了,再次向您求助.


您看SHEET6, SHEET7就行. 其它表格我没删.


arr(i + 5) = arr(i + 5) & Space(10) & s(2)       '这里需要改下,可能其它地方也要进行变动, 请老师帮忙,您有空时帮忙构思，谢谢！



下面是我原来在表格进行替换中文的.

Sub 替换()                           
    arr = Range("Y3:Y" & Range("Y3").End(xlDown).Row)
    brr = Sheets("Sheet6").UsedRange
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(brr, 1)
            arr(i, 1) = Replace(arr(i, 1), brr(j, 1), brr(j, 2))
        Next
    Next
    Range("BF3").Resize(UBound(arr, 1), 1) = arr


End Sub

一把小刀闯天下

'文字太多没有图示，无法确定替换还是插入。缺少数据，原来你有3列有用数据现在变成了2列，已给你注释。10楼当时已经提醒过你怎么提问。

'你这如果规则明确我可以给你从零开始写，中间掐一段处理起来挺费劲

'先写给你写一段放在这，规则如果确定再给你修改

Option Explicit

Sub test()
  Dim i, j, ii, brr, filename(), dic, t, s, sht
  If Not getfilename(filename, ThisWorkbook.path, "_cn.txt") Then MsgBox "文件！": Exit Sub
  Set dic = CreateObject("scripting.dictionary")
  sht = Split("sheet6 sheet7")
  ReDim arr(UBound(sht))
  For i = 0 To UBound(sht)
    arr(i) = Sheets(sht(i)).[a1].CurrentRegion
    For j = 1 To UBound(arr(i))
'      If Not dic.exists(arr(i)(j, 1)) Then
        t = Array(i, j)
        dic(arr(i)(j, 1)) = t
'      Else
'        MsgBox "有重复数据：" & sht(i) & Space(2) & arr(i)(j, 1): Exit Sub
'      End If
  Next j, i
  For ii = 1 To UBound(filename)
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Open
      .LoadFromFile filename(ii)
      .Charset = "UTF-8"
      .Position = 2
      brr = Split(.ReadText, vbNewLine)
      .Close
    End With
    For i = 0 To UBound(brr)
      If Left(brr(i), 1) = "=" Then Exit For '开始标志位
    Next
    If i = UBound(brr) + 1 Then MsgBox "格式问题：" & filename(ii): Exit Sub '无标志位
    For i = i + 3 To UBound(brr) Step 10 '有效数据开始行，每段10行
      If Left(brr(i), 1) = Space(1) Then Exit For '结束标志
      t = Split(brr(i), Space(1))
      For j = 1 To UBound(t)
        If Len(t(j)) Then
          If dic.exists(t(j)) Then
            s = dic(t(j))
            brr(i + 1) = arr(s(0))(s(1), 2)
            brr(i + 1) = Space(39) & brr(i + 1)
            brr(i + 3) = brr(i + 3) & arr(s(0))(s(1), 3)
'            brr(i + 5) = brr(i + 5) & arr(s(0))(s(1), 3)'没有数据可写
          End If
          Exit For
        End If
    Next j, i
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Charset = "utf-8"
      .Open
      .WriteText Join(brr, 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

FRANKEXCELVB

感谢老师，我试下，理清思路，再向您请教，非常感谢。

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-25 07:26
'文字太多没有图示，无法确定替换还是插入。缺少数据，原来你有3列有用数据现在变成了2列，已给你注释。10 ...

老师,谢谢您. 您看图片这样描述要求,可以吗?

產品內容,產品顏色明細        的中文插入, 还是从SHEET7里面调用;

包裝       的中文翻译,我想      让它到 SHEET6里面, 根据英文/中文的对应关系表, 进行替换,把换好后的中文,连同原来的英文前面相对应数字一起放在后面,实现翻译的效果.

另外,对于文件的翻译,我想自己手动选择,不要一下子都全部运行了.

FRANKEXCELVB

FRANKEXCELVB 发表于 2019-3-25 12:53
老师,谢谢您. 您看图片这样描述要求,可以吗?

產品內容,產品顏色明細        的中文插入, 还是从SHEET7 ...

另外,我想让 SHEET7里面有重复字段存在,因为定期会往里面加货号数据,保不齐有和前面一样的.

一把小刀闯天下

'sheet7工作表中A列有重复数据，注释行注释去除会有提示，，，

Option Explicit

Sub test()
  Dim i, j, k, ii, brr, filename(), dic, t, s, ss, sht
  If Not getfilename(filename, ThisWorkbook.path, "_cn.txt") Then MsgBox "文件！": Exit Sub
  Set dic = CreateObject("scripting.dictionary")
  sht = Split("sheet6 sheet7")
  ReDim arr(UBound(sht))
  For i = 0 To UBound(sht)
    arr(i) = Sheets(sht(i)).[a1].CurrentRegion
    For j = 1 To UBound(arr(i))
'      If Not dic.exists(arr(i)(j, 1)) Then
        t = Array(i, j)
        dic(arr(i)(j, 1)) = t
'      Else
'        MsgBox "有重复数据：" & sht(i) & Space(2) & arr(i)(j, 1): Exit Sub
'      End If
  Next j, i
  For ii = 1 To UBound(filename)
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Open
      .LoadFromFile filename(ii)
      .Charset = "UTF-8"
      .Position = 2
      brr = Split(.ReadText, vbNewLine)
      .Close
    End With
    For i = 0 To UBound(brr)
      If Left(brr(i), 1) = "=" Then Exit For '开始标志位
    Next
    If i = UBound(brr) + 1 Then MsgBox "格式问题：" & filename(ii): Exit Sub '无标志位
    For i = i + 3 To UBound(brr) Step 10 '有效数据开始行，每段10行
      If Left(brr(i), 1) = Space(1) Then Exit For '结束标志
      t = Split(brr(i), Space(1))
      For j = 1 To UBound(t)
        If Len(t(j)) Then
          If dic.exists(t(j)) Then
            s = dic(t(j))
            brr(i + 1) = arr(s(0))(s(1), 2)
            brr(i + 1) = Space(39) & brr(i + 1)
            brr(i + 3) = brr(i + 3) & Space(10)
            brr(i + 3) = brr(i + 3) & arr(s(0))(s(1), 3)
          End If
          Exit For
        End If
      Next
      t = Trim(Split(brr(i + 5), ":")(1))
      t = Split(t, "-")
      For j = 0 To UBound(t)
        For k = 1 To Len(t(j))
          If Not IsNumeric(Mid(t(j), k, 1)) Then
            ss = Mid(t(j), k)
            If dic.exists(ss) Then
              s = dic(ss)
              ss = arr(s(0))(s(1), 2)
              t(j) = Left(t(j), k - 1) & ss
            End If
            Exit For
          End If
      Next k, j
      t = Join(t, "-")
      brr(i + 5) = brr(i + 5) & Space(10) & t
    Next
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Charset = "utf-8"
      .Open
      .WriteText Join(brr, 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

FRANKEXCELVB

一把小刀闯天下 发表于 2019-3-25 13:28
'sheet7工作表中A列有重复数据，注释行注释去除会有提示，，，

Option Explicit

非常好用,感谢老师的帮助.