- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2013-7-3 14:54
| 只看該作者
回復 1# smartpearl
試試看- Option Explicit
- Sub Ex()
- Dim 原始的資料 As Range, xType(), AR(1 To 2)
- Dim 資料表 As Worksheet, I As Integer, ii As Integer, R As Integer
- xType = Array("Actual", "A_REAL", "Plan", "ALLOCATE", "Non_Plan") '5種 Type
- Set 原始的資料 = Sheets("SHEET1").Range("a1").CurrentRegion
- Set 資料表 = Sheets("SHEET2")
- 資料表.Cells.Clear
- '*********************************************************************
- '原始的資料於工作表, A1開始放置
- '注意 : 原始的資料,CRP(F欗)的第1個有值: 補上其他位置的值,使用這行程式碼
- 原始的資料.Columns(6).SpecialCells(xlCellTypeBlanks).Value = "=R[-1]C"
- '*********************************************************************
- I = 1
- Do
- With 原始的資料
- R = 資料表.Cells(資料表.Rows.Count, 1).End(xlUp).Row
- If I >= 2 Then
- For ii = 0 To UBound(xType)
- R = R + 1
- With .Rows(I)
- AR(1) = Array(.Cells(2), .Cells(7), .Cells(4), .Cells(5), .Cells(6), .Cells(8))
- 'CUSTOMER TESTER DEVICE DEVICE_GRP CRP TIME
- 資料表.Cells(R, 1).Resize(1, 6) = AR(1)
- If .Cells(9) = xType(ii) Then
- AR(2) = Application.Transpose(Application.Transpose(.Cells(9).Resize(, .Columns.Count - 8)))
- 資料表.Cells(R, 7).Resize(1, UBound(AR(2))) = AR(2)
- With 原始的資料.Rows(I + 1)
- '比對上下欄的資料
- If Join(Array(.Cells(0, 2), .Cells(0, 7), .Cells(0, 4), .Cells(0, 5), .Cells(0, 6)), ",") = Join(Array(.Cells(2), .Cells(7), .Cells(4), .Cells(5), .Cells(6)), ",") Then
- I = I + 1 '比對上下欄的資料相同
- End If
- End With
- Else
- 資料表.Cells(R, 7) = xType(ii)
- End If
- End With
- Next
- Else
- With .Rows(1)
- ' Array(.Cells(2), .Cells(7), .Cells(4), .Cells(5), .Cells(6), .Cells(8), .Cells(9))
- 'CUSTOMER TESTER DEVICE DEVICE_GRP CRP TIME TYPE
- 資料表.Cells(R, 1).Resize(1, 7) = Array(.Cells(2), .Cells(7), .Cells(4), .Cells(5), .Cells(6), .Cells(8), .Cells(9))
- AR(1) = .Range(.Cells(10), .Cells(.Columns.Count))
- With 資料表.[a1].End(xlToRight).Offset(, 1).Resize(1, UBound(AR(1), 2))
- .Value = AR(1)
- .NumberFormatLocal = "m/d;@"
-
- End With
-
- End With
- End If
- I = I + 1
- End With
- Loop Until I > 原始的資料.Rows.Count
- With 資料表.Range("A1").CurrentRegion
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- .WrapText = False
- For I = 2 To .Rows.Count Step 5
- .Rows(I & ":" & I + 4).BorderAround 1
- Application.DisplayAlerts = False
- For ii = 1 To 5
- .Columns(ii).Range("A" & I & ":A" & I + 4).MergeCells = True
- Next
- Application.DisplayAlerts = True
- Next
- End With
- End Sub
|
|
發表於 2013-7-2 22:11
| 
