准提部林

Sub TEST()
Dim Arr, TS, Cr, C%, i&, j%, N&
Sheets("輸出").UsedRange.Offset(4, 0).EntireRow.Delete
Arr = Range([資料!A1], Sheets("資料").UsedRange)
Cr = Array(, 2, 3, 4, 5, 6, 7, 8, 18, 19, 20, 22, 22, 23, 23)
For i = 6 To UBound(Arr)
    If Arr(i, 20) <> "" Then N = N + 1 Else GoTo i01
    For j = 1 To UBound(Cr)
        Arr(N, j) = Arr(i, Cr(j))
        If j = 11 Or j = 13 Then Arr(N, j) = Left(Arr(N, j), 8)
        If j = 12 Or j = 14 Then Arr(N, j) = Right(Arr(N, j), 5)
    Next j
i01: Next i
If N = 0 Then Exit Sub
Application.ScreenUpdating = False
With [A5].Resize(N, UBound(Cr))
     .Value = Arr
     .Borders.LineStyle = 1
     .Sort key1:=.Item(2), key2:=.Item(10), Header:=xlNo
     With Range(.Columns(8), .Columns(9))
          For Each TS In Array("AA_A", "BBB_B", "CC_C", "DDD_D", "EEE_D", "FFF_F", "GGG_G", "HH_G", "MM_M", "LLL_L", "QQQ_L", "NNN_N", "TTT_N")
              Cr = Split(TS, "_")
              .Replace "*" & Cr(0) & "*", String(3, Cr(1))
          Next
     End With
End With
End Sub

寫法大致相同~~
排序為何只有前10欄, 那後面不就亂了套???

n7822123

回復 11# 准提部林

啊~感謝準大糾錯  

我把原程式 的這行 .Range("a5：o" & [j1048576].End(xlUp).Row).Select

看成是A~J欄了   ，應該是A~O才對 ，看太快看錯了.....

原PO還沒發現到..... 程式修改如下(因為都是A~O，與上面合併)

Sub main()
Application.ScreenUpdating = False
Worksheets("輸出").Activate
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 18, 19, 20, 22, 22, 23, 23)
Set Rg = [資料!A1048576].End(xlUp)
If Rg.Row = 1 Then Exit Sub
[A4].CurrentRegion.Resize(, 15).Offset(1).Clear
Arr = Range([資料!W6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)
[A2] = [資料!A2]
For R = 1 To UBound(Brr)
  If Arr(R, 20) <> "" Then
      Ro = Ro + 1
      For C = 1 To 14
            If C <= 10 Then Brr(Ro, C) = Arr(R, Ci(C))
            If C = 11 Or C = 13 Then Brr(Ro, C) = Left(Arr(R, Ci(C)), 8)
            If C = 12 Or C = 14 Then Brr(Ro, C) = Right(Arr(R, Ci(C)), 5)
      Next C
  End If
Next R
With [A5].Resize(Ro, 15)  'A~O欄填值+劃框線+排序
    .Value = Brr
    .Borders.LineStyle = xlContinuous
    .Sort key1:=.Item(2), key2:=.Item(10), Header:=xlNo
End With
With [H5].Resize(Ro, 2)   'H、I欄做取代
    .Replace "*AA*", "AAA"
    .Replace "*BBB*", "BBB"
    .Replace "*CC*", "CCC"
    .Replace "*DDD*", "DDD"
    .Replace "*EEE*", "DDD"
    .Replace "*FFF*", "FFF"
    .Replace "*GGG*", "GGG"
    .Replace "*HH*", "GGG"
    .Replace "*MM*", "MMM"
    .Replace "*LLL*", "LLL"
    .Replace "*QQQ*", "LLL"
    .Replace "*NNN*", "NNN"
    .Replace "*TTT*", "NNN"
End With
End Sub

b9208

回復 12# n7822123
准大、龍大
非常感謝二位大大指導