麻辣家族討論版版 - Powered by Discuz! Board

Sub 迴圈()
Dim Rng As Range, M As Variant, E
Set Rng = Sheets("SHEET3").Range("A:A")
Sheets("SHEET2").UsedRange.Offset(1).Clear
For Each E In Sheets("SHEET1").Range("A:A").SpecialCells(xlCellTypeConstants) '特殊儲存格(字串),排除空白儲存格.
If E.Row > 1 Then '排除表頭
M = Application.Match(E, Rng, 0) '搜尋Device在Rng的位置=列號
If IsNumeric(M) Then '是數字:有找到Device在Rng的位置
With Sheets("SHEET2").Cells(Sheets("SHEET2").Rows.Count, "A").End(xlUp).Offset(1) 'SHEET2 A欄寫上的位置
'SHEET2 A欄由下往上到有資料儲存格的下一列
.Range("A1") = Rng.Cells(M, 2) 'Package 在 Device 的右欄
.Range("B1") = E 'Device
.Range("D1") = E.Range("C1") 'Datecode
.Range("E1") = E.Range("D1") 'Wafer ID
'*************************
'等候你的條件說明後寫程式碼
'*************************
End With
End If
End If
Next
End Sub

複製代碼

Sub 迴圈()
Dim Rng(1 To 6) As Range, E As Variant, M As Variant, M1 As Variant, i As Integer, ii As Integer
With Sheets("sheet1") '客戶資料
If .[COUNTA(A:A)] <> .UsedRange.Rows.Count Then .Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete '刪除空白列
For E = 0 To 14
.[E1].Offset(, E).Name = .[E1].Offset(, E) & "值" '定義名稱: B01 B02 B03 B04.....
Next
End With
Sheets("Sheet2").UsedRange.Offset(1).Clear '清除第二列(含)後的資料
Set Rng(1) = Sheets("Sheet1").UsedRange.Columns(1) '客戶資料
Set Rng(2) = Sheets("Sheet2").Range("A:A") '要寫入的範圍
Set Rng(3) = Sheets("Sheet3").Range("A:A") 'Device
Set Rng(4) = Sheets("Sheet4").Range("A:A") 'Package
Set Rng(5) = Sheets("Sheet4").Range("B1:N1") 'Test out Q'ty,RG/SWT ....
For Each E In Rng(1).Cells '客戶資料
If E.Row > 1 Then '排除表頭
M = Application.Match(E, Rng(3), 0) '搜尋Sheet1的Device在Sheet3的列位
If IsNumeric(M) Then M1 = Application.Match(Rng(3).Cells(M, 2), Rng(4), 0)
'M1: 傳回Sheet3的Package在Sheet4的列位
If IsNumeric(M) And IsNumeric(M1) Then
i = Application.CountA(Rng(2)) + 1 '計算有文字儲存格數
With Sheets("SHEET2").Cells(i, "A") 'SHEET2 A欄寫上的位置
.Range("A1") = Rng(4).Cells(M1, 1) 'Sheet4對應的Package
.Range("B1") = E 'Device
.Range("D1") = E.Range("C1") 'Datecode
.Range("E1") = E.Range("D1") 'Wafer ID
For Each C In Rng(5).Offset(M1 - 1) '比對對應的'B01 B02 B03 B04.....
If C <> "" Then
M = Application.Match(C.Parent.Cells(1, C.Column), Rng(2).Cells(1).EntireRow, 0) '搜尋Sheets("Sheet2")的欄位
'M=B01 B02 B03 B04.....上方第一列標頭在Sheet2第一列的欄位數
For ii = 0 To UBound(Split(C, "+")) '字串以"+"分割成陣列
'.Parent.Cells(i, M) = .Parent.Cells(i, M) + Range(Split(C, "+")(ii)).Offset(E.Row - 1) 'SHEET4的格式 B01值 B02值 B03值 B04值.....
.Parent.Cells(i, M) = .Parent.Cells(i, M) + Range(Split(C, "+")(ii) & "值").Offset(E.Row - 1) 'SHEET4的格式 B01 B02 B03 B04.....
'.Parent -> Sheets("SHEET2")
'Range(Split(C, "+")(ii) & "值"): 工作表上所定義名稱的位置
Next
End If
Next
End With
Else
If Rng(6) Is Nothing Then
Set Rng(6) = E.EntireRow '比對不到的Device,Package
Else
Set Rng(6) = Union(Rng(6), E.EntireRow) 'Union 方法傳回兩個或多個範圍的合併範圍。
End If
End If
End If
Next
If Not Rng(6) Is Nothing Then Rng(6).Delete
End Sub

複製代碼