- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
3#
發表於 2018-6-5 09:24
| 只看該作者
本帖最後由 GBKEE 於 2018-6-11 14:09 編輯
回復 2# newstarmoon
試試看- Option Explicit
- Sub Ex()
- Dim AR(), Ar1(), Ar2(), i As Long, ii As Long, iii As Long, Msg As String
- Dim xRow As Integer
- Ar1 = Array("a", "b", "d") '你的C欄隱藏了
- ReDim AR(1 To UBound(Ar1) + 1)
- Sheets("運算").UsedRange.Clear
- With Sheets("工作表")
- For i = 1 To UBound(Ar1) + 1
- ii = IIf(.Cells(Rows.Count, Ar1(i - 1)).End(xlUp).Row > ii, .Cells(Rows.Count, Ar1(i - 1)).End(xlUp).Row, ii)
- '如果某一列的資料有100行，而第5行是空白
- '***必須找出所有欄位中最後資料有的列號 ***
- Next
- For i = 1 To UBound(Ar1) + 1
- AR(i) = Application.WorksheetFunction.Transpose(.Range(Ar1(i - 1) & "1").Resize(ii).Value)
- Next
- End With
- With Sheets("藥材檔")
- Ar1 = .Range(.[A5], .[A5].End(xlDown)).Resize(, 5).Value
- For i = 1 To .[A5].End(xlDown).Row - 4
- Ar1(i, 5) = .Range("DK" & i + 4) '**加入"DK"欄
- Next
- End With
- For i = 2 To UBound(AR(1)) '藥代
- '**************************
- '"工作表"
- 'AR(1)(i)=>藥代 AR(2)(i)=>藥單名 AR(3)(i)=>健保碼
- '**************************
- '"藥材檔"
- 'Ar1(ii, 1)=>藥代 Ar1(ii, 2)=>代號 Ar1(ii, 3)=>健保碼 Ar1(ii, 4)=>藥名
- 'Ar1(ii, 5)=>DK
- '**************************
-
- Msg = ""
- For ii = 1 To UBound(Ar1)
- If AR(1)(i) <> "" And Ar1(ii, 1) <> AR(1)(i) Then '藥代不相同
- 'InStr(Ar1(ii, 5), (AR(3)(i))) ->查看有無相同健保碼
- 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
- Msg = Msg & IIf(Msg <> "", ",", "") & ii '比對到帶入
- End If
- End If
- Next
- If Msg <> "" Then
- With Sheets("運算").Cells(Rows.Count, "A").End(xlUp)
- xRow = IIf(.Row = 1, 0, 2)
- Ar2 = Application.Index(Application.WorksheetFunction.Transpose(AR), 1)
- .Offset(xRow).Resize(, UBound(Ar2)) = Ar2
- Ar2 = Application.Index(Application.WorksheetFunction.Transpose(AR), i)
- .Offset(xRow + 1).Resize(, UBound(Ar2)) = Ar2
- Ar2 = Array("藥代", "代號", "健保碼", "藥名", "DK欄")
- .Offset(xRow + 2).Resize(, UBound(Ar2) + 1) = Ar2
- End With
- With Sheets("運算").Cells(Rows.Count, "A").End(xlUp).Offset(1)
- For iii = 0 To UBound(Split(Msg, ","))
- Ar2 = Application.Index(Ar1, Split(Msg, ",")(iii))
- .Offset(iii).Resize(, UBound(Ar2)) = Ar2
- Next
- End With
- End If
- Next
- End Sub
|
|
發表於 2018-5-29 02:01
| 
