WT.Range("A" & K & ":O" & K).Select
Selection.Borders.LineStyle = xlContinuous
K = K + 1
End If
Next i
.Range("a5:o" & [j1048576].End(xlUp).Row).Select
Selection.Sort key1:=.[B5], key2:=.[J5], Header:=xlNo
End With
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
Arr = Range([資料!AD6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)
[A2] = [資料!A2]
For R = 1 To UBound(Brr): For C = 1 To 14
If C <= 10 Then Brr(R, C) = Arr(R, Ci(C))
If C = 11 Or C = 13 Then Brr(R, C) = Left(Arr(R, Ci(C)), 8)
If C = 12 Or C = 14 Then Brr(R, C) = Right(Arr(R, Ci(C)), 5)
Next C: Next R
With [A5].Resize(UBound(Brr), 15) 'A~O欄填值+劃框線
.Value = Brr
.Borders.LineStyle = xlContinuous
End With
With [A5].Resize(UBound(Brr), 10) 'A~J欄做排序
.Sort key1:=.Item(2), key2:=.Item(10), Header:=xlNo
End With
With [H5].Resize(UBound(Brr), 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
Sub main()
Application.ScreenUpdating = False
Worksheets("輸出").Activate
Ci = Array(, 2, 3, 4, 5, 6, 7, 8, 28, 29, 30, 32, 32, 33, 33)
Set Rg = [資料!A1048576].End(xlUp)
If Rg.Row = 1 Then Exit Sub
Arr = Range([資料!AG6], Rg)
Brr = [A5].Resize(UBound(Arr), 15)
[A2] = [資料!A2]
For R = 1 To UBound(Brr): For C = 1 To 14
If Arr(R, 30) <> "" Then
If C <= 10 Then Brr(R, C) = Arr(R, Ci(C))
If C = 11 Or C = 13 Then Brr(R, C) = Left(Arr(R, Ci(C)), 8)
If C = 12 Or C = 14 Then Brr(R, C) = Right(Arr(R, Ci(C)), 5)
End If
Next C: Next R
...
...
...作者: b9208 時間: 2020-8-22 21:37
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
End With
With [A5].Resize(Ro, 14) 'A~J欄做排序
.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
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
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 時間: 2020-8-23 20:05
，應該是A~O才對 ，看太快看錯了.....