- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
本帖最後由 准提部林 於 2016-4-2 11:13 編輯
第５點需求不太清楚，先試看看：- Sub 載入()
- Dim Arr, xB As Workbook, BKN, i&, N&, xD, U
- Call 清除
- Set xD = CreateObject("Scripting.Dictionary") '字典檔
- Application.ScreenUpdating = False
- Set xB = Workbooks.Open(ThisWorkbook.Path & "\Christy珠寶更新.xls", ReadOnly:=True) '唯讀開啟檔案
- Arr = Range(xB.Sheets(1).[C1], xB.Sheets(1).Cells(Rows.Count, 2).End(xlUp)) '將資料範圍納入陣列
- xB.Close 0 '關閉檔案
- For i = 2 To UBound(Arr)
- If Left(Arr(i, 1), 2) = "FJ" Or Left(Arr(i, 1), 1) = "W" Then '檢查編號首2或1英文碼
- N = N + 1 '符合者累加1
- Arr(N, 1) = Left(Arr(i, 1), 6) & "-" & Right(Arr(i, 1), 3) '寫入編號
- Arr(N, 2) = Arr(i, 2) '寫入數量
- xD(Arr(N, 1)) = Arr(N, 2) '以編號為key,將數量納入字典檔
- End If
- Next i
- If N > 0 Then Cells(Rows.Count, "H").End(xlUp)(2).Resize(N, 2) = Arr '載入陣列內容
- For Each BKN In Array("F珠寶上落牌", "W珠寶上落牌") '逐一開啟兩個檔案
- Set xB = Workbooks.Open(ThisWorkbook.Path & "\" & BKN & ".xls", ReadOnly:=True) '唯讀開啟檔案
- Arr = xB.Sheets(1).UsedRange '將資料範圍納入陣列
- xB.Close 0 '關閉檔案
- N = 0 '計數器歸0
- For i = 2 To UBound(Arr)
- If Left(Arr(i, 5), 2) = "FJ" Or Left(Arr(i, 5), 1) = "W" Then '檢查編號首2或1英文碼
- N = N + 1 '符合者累加1
- Arr(N, 1) = Left(Arr(i, 5), 6) & "-" & Right(Arr(i, 5), 3) '寫入編號
- Arr(N, 2) = Arr(i, 12) '寫入[是/否]
- Arr(N, 3) = Val(xD(Arr(N, 1))) '寫入數量(從字典檔中取出)
- '↓上/下牌檢查
- Arr(N, 4) = ""
- If Arr(N, 2) = "否" And Arr(N, 3) > 0 Then Arr(N, 4) = "▲上牌": U = U + 1
- If Arr(N, 2) = "是" And Arr(N, 3) = 0 Then Arr(N, 4) = "▼下牌": U = U + 1
- End If
- Next i
- If N > 0 Then Cells(Rows.Count, "C").End(xlUp)(2).Resize(N, 4) = Arr '載入陣列內容
- Next
- Application.ScreenUpdating = True
- If U > 0 Then MsgBox "共有 " & U & " 個項目須處理！ "
- End Sub
- Sub 清除()
- With ActiveSheet
- If .FilterMode Then .ShowAllData
- .UsedRange.Offset(1, 0).EntireRow.Delete
- .[A2].Select
- End With
- End Sub
參考檔案：XLS格式，請自行去套
 FW珠寶上落牌一鍵.rar (72.71 KB)
另一載點：
http://www.funp.net/918457
|
|
發表於 2016-4-2 11:12
| 