GBKEE

回復 2# newstarmoon
試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim AR(), Ar1(), Ar2(), i As Long, ii As Long, iii As Long, Msg As String
   
4.     Dim xRow As Integer
   
5.     Ar1 = Array("a", "b", "d") '你的C欄隱藏了
   
6.     ReDim AR(1 To UBound(Ar1) + 1)
   
7.     Sheets("運算").UsedRange.Clear
   
8.     With Sheets("工作表")
   
9.         For i = 1 To UBound(Ar1) + 1
   
10.             ii = IIf(.Cells(Rows.Count, Ar1(i - 1)).End(xlUp).Row > ii, .Cells(Rows.Count, Ar1(i - 1)).End(xlUp).Row, ii)
    
11.             '如果某一列的資料有100行，而第5行是空白
    
12.             '***必須找出所有欄位中最後資料有的列號 ***
    
13.         Next
    
14.         For i = 1 To UBound(Ar1) + 1
    
15.             AR(i) = Application.WorksheetFunction.Transpose(.Range(Ar1(i - 1) & "1").Resize(ii).Value)
    
16.         Next
    
17.     End With
    
18.     With Sheets("藥材檔")
    
19.         Ar1 = .Range(.[A5], .[A5].End(xlDown)).Resize(, 5).Value
    
20.         For i = 1 To .[A5].End(xlDown).Row - 4
    
21.             Ar1(i, 5) = .Range("DK" & i + 4) '**加入"DK"欄
    
22.         Next
    
23.     End With
    
24.     For i = 2 To UBound(AR(1)) '藥代
    
25.         '**************************
    
26.         '"工作表"
    
27.         'AR(1)(i)=>藥代    AR(2)(i)=>藥單名    AR(3)(i)=>健保碼
    
28.         '**************************
    
29.         '"藥材檔"
    
30.         'Ar1(ii, 1)=>藥代    Ar1(ii, 2)=>代號    Ar1(ii, 3)=>健保碼  Ar1(ii, 4)=>藥名
    
31.         'Ar1(ii, 5)=>DK
    
32.         '**************************
    
33.         
    
34.         Msg = ""
    
35.         For ii = 1 To UBound(Ar1)
    
36.             If AR(1)(i) <> "" And Ar1(ii, 1) <> AR(1)(i) Then    '藥代不相同
    
37.                 'InStr(Ar1(ii, 5), (AR(3)(i))) ->查看有無相同健保碼
    
38.                 If UCase(Ar1(ii, 4)) = UCase(AR(2)(i)) Or UCase(Ar1(ii, 3)) = UCase(AR(3)(i)) Or InStr(Ar1(ii, 5), (AR(3)(i))) Then
    
39.                     Msg = Msg & IIf(Msg <> "", ",", "") & ii  '比對到帶入
    
40.                 End If
    
41.             End If
    
42.         Next
    
43.         If Msg <> "" Then
    
44.             With Sheets("運算").Cells(Rows.Count, "A").End(xlUp)
    
45.               xRow = IIf(.Row = 1, 0, 2)
    
46.                 Ar2 = Application.Index(Application.WorksheetFunction.Transpose(AR), 1)
    
47.                 .Offset(xRow).Resize(, UBound(Ar2)) = Ar2
    
48.                 Ar2 = Application.Index(Application.WorksheetFunction.Transpose(AR), i)
    
49.                 .Offset(xRow + 1).Resize(, UBound(Ar2)) = Ar2
    
50.                 Ar2 = Array("藥代", "代號", "健保碼", "藥名", "DK欄")
    
51.                 .Offset(xRow + 2).Resize(, UBound(Ar2) + 1) = Ar2
    
52.             End With
    
53.             With Sheets("運算").Cells(Rows.Count, "A").End(xlUp).Offset(1)
    
54.                For iii = 0 To UBound(Split(Msg, ","))
    
55.                 Ar2 = Application.Index(Ar1, Split(Msg, ",")(iii))
    
56.                .Offset(iii).Resize(, UBound(Ar2)) = Ar2
    
57.                Next
    
58.             End With
    
59.         End If
    
60.     Next
    
61. End Sub

複製代碼