yvonnethwdly的部落格

EXCEL VBA．統計外部檔案各項目數量．與當前工作表比對驗證
　　　　　　　　　　　　　　　　　　　　　　　　　＜．准提部林．＞
－－－���－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
■程式碼：
　Dim BookArr, ExDic As Object, ExPath$
　
　Sub 驗證()
　Dim y&, UU, GG, uP$, xR As Range
　ExPath = ThisWorkbook.Path & "\"
　Call 檔案清單: If Not IsArray(BookArr) Then Exit Sub
　Call 統計資料: If ExDic.Count = 0 Then Exit Sub
　ActiveSheet.Unprotect "123"
　[H:K].ClearContents
　y = Cells(Rows.Count, "C").End(xlUp).Row
　For Each xR In Range("C2:C" & y + 1)
　　If xR = "" Then GoTo 102
　　UU = xR(1, 3) - xR(1, 4)
　　If UU <= 0 Then xR(1, 6) = "不比對": GoTo 102
　　GG = ExDic(xR.Value)
　　ExDic.Remove xR.Value
　　If UU = GG Then xR(1, 6) = "正確": GoTo 102
　　xR(1, 6) = "錯誤": xR(1, 7) = GG - UU
　102: Next
　y = ExDic.Count
　If y > 0 Then
　　[J1] = "遺漏號碼": [K1] = "數量"
　　[J2].Resize(y) = Application.Transpose(ExDic.keys)
　　[K2].Resize(y) = Application.Transpose(ExDic.items)
　End If
　ActiveSheet.Protect "123"
　End Sub
　
　
　Sub 統計資料()
　Dim uBook As Workbook, uSht As Worksheet, uR As Range, BT, y&
　Set ExDic = CreateObject("Scripting.Dictionary")
　Application.ScreenUpdating = False
　For Each BT In BookArr
　　For Each uBook In Workbooks
　　　If uBook.Name = BT Then Exit For
　　Next
　　If uBook Is Nothing Then Set uBook = Workbooks.Open(ExPath & BT)
　　Set uSht = uBook.ActiveSheet
　　y = uSht.Cells(Rows.Count, "B").End(xlUp).Row
　　For Each uR In uSht.Range("B2:B" & y + 1)
　　　If uR <> "" Then ExDic(uR.Value) = ExDic(uR.Value) + uR(1, 2)
　Next
　uBook.Close SaveChanges:=False
　指揮棒高雄鳳山台北松山新莊泰山阿囉哈led總匯: Next
　End Sub
　
　
　Sub 檔案清單()
　Dim sF$, FileStr$
　BookArr = ""
　Do
　　If sF = "" Then sF = Dir(ExPath & "*.xls") Else sF = Dir
　　If sF = "" Then Exit Do
　　If sF <> ThisWorkbook.Name Then FileStr = FileStr & "|" & sF
　Loop
　FileStr = Mid(FileStr, 2)
　If FileStr <> "" Then BookArr = Split(FileStr, "|")
　End Sub　
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
＜範例檔＞下載：
檔案名稱：20140129v01(活頁簿抓取比對).rar
下載連結：http://www.funp.net/501678
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－