- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
2#
發表於 2014-3-23 05:37
| 只看該作者
本帖最後由 yen956 於 2014-3-23 05:40 編輯
試試看:
 - 'Sheet1 的VBA
- '資料整理
- Private Sub CommandButton1_Click()
- Dim sh1, sh2 As Worksheet, rngA As Range
- Dim endRow As Integer
- Set sh1 = Sheets(1): Set sh2 = Sheets(2)
-
- endRow = sh1.[A1].End(xlDown).Row
- sh2.[B1].Resize(endRow, 2) = ""
-
- '將 sh1.欄A 按升冪排序
- sh1.[A1].Resize(endRow, 3).Sort _
- Key1:=sh1.[A1], Order1:=xlAscending, _
- Key2:=sh1.[C1], Order2:=xlAscending, _
- Header:=xlYes
-
- '重新定義名稱 "x" 的範圍(sh1.欄A)
- ActiveWorkbook.Names("x").Delete
- ActiveWorkbook.Names.Add Name:="x", RefersToR1C1:="=Sheet1!R1C1:R" & endRow & "17C1"
- End Sub
-
- 'Sheet2 的VBA
- '欲在sh2.欄A 資料變更時觸發事件, 可用 Intersect 方法完成：
- Private Sub Worksheet_Change(ByVal Target As Range)
- Dim sh1, sh2 As Worksheet, rngA As Range
- Dim endRow, cnt As Integer
- Set sh1 = Sheets(1): Set sh2 = Sheets(2)
-
- '將公式 MATCH 輸入 sh2.[F1]
- '將 sh2.欄A 所輸入的 編號, 用公式 MATCH 獲取 對應到 sh1.欄A 的起始列號
- sh2.[F1] = "=MATCH(E1, x, 0)"
-
- endRow = sh1.[A1].End(xlDown).Row
-
- '限定 資料變更時觸發事件 的有效範圍在 rngA 內
- Set rngA = sh2.[A1].Resize(endRow, 1)
-
- If Not Intersect(Target, rngA) Is Nothing Then
-
- '將剛剛變更的 Target, 存入 sh2.[E1], 供 sh2.[F1] 的公式 MATCH 比對用
- sh2.[E1] = Target
-
- '若 sh2.[F1] 是數值, 表示剛剛輸入了 有效數字
- If Application.IsNumber(sh2.[F1]) Then
- cnt = 0
- Do
- Target.Offset(cnt, 1) = sh1.Cells(cnt + sh2.[F1], 2)
- Target.Offset(cnt, 2) = sh1.Cells(cnt + sh2.[F1], 3)
- cnt = cnt + 1
- Loop Until sh1.Cells(cnt + sh2.[F1], 1) > sh1.Cells(sh2.[F1], 1) Or sh1.Cells(cnt + sh2.[F1], 1) = ""
- End If
- End If
- End Sub
|
|
