Andy2483

回復 29# 198188


   猜亂碼有關,試試看如下

下載 (86.31 KB)

2024-1-3 09:41

修改為如下再試試

下載 (74.83 KB)

2024-1-3 09:42

198188

回復 31# Andy2483


    我一改，excel 就自動關閉。:'(  試了很多次，都是這樣

Andy2483

回復 32# 198188


    把資料與VBA搬到新開檔案試試看

198188

回復 33# Andy2483


    重複不斷試了幾十遍，終於可以了。謝謝。

Andy2483

回復 34# 198188


    謝謝前輩回復
如果有測試結論或解決方法可以分享一下

198188

回復 35# Andy2483


    根據你說的那樣，亂碼換成英文，這樣就可以了
另外還有一個小的問題
能不能獨立做一個VBA 把全部sheets 裏面的文字按照附件Translate這個表裏的資料進行取代，
舉例
排櫃表        Container Maps
貨櫃號        Project Name
貨物        Description
貨櫃尺寸        Container Size
出貨日期        Ex-Work Date
櫃號        Container No
制表人        Prepared By
制表日        Date
上架        Upper Crate
下架        Lower Crate
車頭        Container Head
架長        Shelf Length

如果sheet 裏面有“排櫃表”的字眼，那麽執行程式后，“Container Maps” 取代“排櫃表”

Andy2483

回復 36# 198188


    錄製巨集就可以做,請先試試看
再以副程式的方式排入主程式裡執行

Andy2483

回復 36# 198188

Option Explicit
Sub Map()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Brr, Crr, Ar, Arr, V, Z, A, i&, R&, C%, j%, T$, K$, Qs$, Qd$, No$, Mk$, Q$, S%
For i = Worksheets.Count To 4 Step -1: Worksheets(i).Delete: Next
Set Z = CreateObject("Scripting.Dictionary")
Brr = Sheets(3).UsedRange
For i = 1 To UBound(Brr): Z(Trim(Brr(i, 1))) = Trim(Brr(i, 2)): Next: S = Z.Count
Brr = Union(Sheets(1).UsedRange, Sheets(1).UsedRange.Offset(1))
Crr = Range(Sheets(2).[A1], Sheets(2).UsedRange): K = [B1]
For i = 1 To UBound(Brr) - 1
   If InStr(Brr(i, 1), Left(K, 4)) = 0 Then GoTo i01
   A = Split(Replace(Brr(i, 1), "  ", " "), " "): Q = Mid(A(0), 5, 4): Qd = A(1)
   If UBound(A) > 1 Then Qs = A(UBound(A)) Else Qs = ""
   A = Z(Q): R = Z(Q & "/r"): C = 1
   If Not IsArray(A) Then A = Crr: A(3, 2) = Q: A(3, 6) = Qs: A(3, 9) = Qd: A(4, 13) = Date: R = 5
   R = R + 1: V = A(R, 2)
   If InStr(Brr(i, 2), V) = 0 Or R = 10 Then GoTo i01
   For j = 2 To UBound(Brr, 2)
      C = C + 2: T = Trim(Brr(i, j)): If T = "" Then GoTo j01
      If InStr(T, V) Then
         A(R, C) = Mid(T, 4, 6): A(R, C + 1) = Replace(Mid(T, 11), ")", "")
         Else
         Ar = Split(T, Chr(10))
         For Each Arr In Ar
            If Not Split(Arr & " ", " ")(1) Like "[A-z][A-z]" Then GoTo j01
            No = No & Chr(10) & Split(Arr, " ")(0): Mk = Mk & Chr(10) & Mid(Arr, InStr(Arr, Split(Arr, " ")(1)))
         Next
         A(R, C) = Mid(No, 2): A(R, C + 1) = Mid(Mk, 2): No = "": Mk = ""
      End If
j01: Next
   Z(Q) = A: Z(Q & "/r") = R
i01: Brr(i + 1, 1) = IIf(Brr(i + 1, 1) = "", Brr(i, 1), Brr(i + 1, 1))
Next
If Z.Count = 0 Then Exit Sub
For Each A In Z.KEYS
   If Not IsArray(Z(A)) Then GoTo A01 Else Sheets(2).Copy After:=Worksheets(Sheets.Count)
   ActiveSheet.Name = A '"Result " & A
   [A1].Resize(UBound(Z(A)), UBound(Z(A), 2)) = Z(A)
   For i = 0 To S - 1: ActiveSheet.UsedRange.Replace Z.KEYS()(i), Z.ITEMS()(i), Lookat:=xlPart: Next
A01: Next
Application.Goto Sheets(1).[A1]
End Sub

198188

回復 38# Andy2483


   我自己加了翻譯的程式，但是我在excel加插一個SHEET 后，執行你的那個VBA，會刪除我加插的那個SHEET. 請問是哪裏的問題？

Andy2483

回復 39# 198188


For i = Worksheets.Count To 3 Step -1
換成
For i = Worksheets.Count To 4 Step -1

PS:
試試#38