【資料名稱】：VBS數(shù)據(jù)核對

【資料作者】：sanren

【資料日期】：2013-5

【資料語言】：中文

【資料格式】：其它

【資料目錄和簡介】：

Function getFilesPath() As String
Dim Shell, myPath
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForFolder(0, "請選擇文件夾", 0, 0)
If Not myPath Is Nothing Then
'MsgBox myPath.self.Path
Set Shell = Nothing
'Set myPath = Nothing
getFilesPath = myPath.self.Path
End If
End Function


Sub 合并()
Dim myPath$, myFile$, myFile14$, myFile15$, myFile16$, myTMP$, address$, kpiName$, sheetName$, TMP As Workbook, AK As Workbook, AK15 As Workbook, AK16 As Workbook, aRow%, tRow%, i%, j%, k%, r%, rc%, cc%, m%, devCount%, findCount%, index%
Dim arr(1 To 100, 1 To 1)'創(chuàng)建一個(gè)可以容下100行1列的數(shù)組空間，記錄計(jì)算結(jié)果

Application.ScreenUpdating = False'凍結(jié)屏幕，以防屏幕抖動(dòng)
'myPath = ThisWorkbook.Path & "\" '分表\" '把文件路徑定義給變量
myPath = getFilesPath
'myPath = "D:\000\EMS\test" '調(diào)試用
'myPath = "D:\000\EMS\20130419"

If myPath = "" Then
MsgBox "沒有選中文件夾，退出！"
Exit Sub'退出過程。
End If
myPath = myPath & "\"
'Exit Sub'退出過程。

'myFile = Dir(myPath & "*.xls") '依次找尋指定路徑中的*.xls文件
myFile14 = Dir(myPath & "*.14.csv")'依次找尋指定路徑中的*.xls文件
'myFile15 = Dir(myPath & "*.15.csv")'依次找尋指定路徑中的*.xls文件
'myFile16 = Dir(myPath & "*.16.csv")'依次找尋指定路徑中的*.xls文件
'MsgBox myFile14



findCount = 0
index = 1'模板中sheet頁序列
'tRow = ThisWorkbook.Sheets(2).UsedRange.Rows.Count

Do While myFile14 <> ""'當(dāng)指定路徑中有文件時(shí)進(jìn)行循環(huán)

If myFile14 <> ThisWorkbook.Name Then
'MsgBox myFile14
Set AK14 = Workbooks.Open(myPath & myFile14)'打開14庫的文件

'最大行數(shù)、列數(shù)
rc = AK14.Sheets(1).UsedRange.Rows.Count
cc = AK14.Sheets(1).UsedRange.Columns.Count

myFile = SplitFileName(myFile14, ".")
myFile15 = SplitFileName(myFile14, ".") & ".15.csv"
myFile16 = SplitFileName(myFile14, ".") & ".16.csv"
'MsgBox "myFile15=" & myFile15 & "myFile16=" & myFile16


Set AK15 = Workbooks.Open(myPath & myFile15)'打開15庫的文件


Set AK16 = Workbooks.Open(myPath & myFile16)'打開14庫的文件

'AK16.Sheets(1).Columns(cc).NumberFormatLocal = "0_ "

sheetName = "kpi" & index

'Application.DisplayAlerts = False '刪除工作表警告提示去消
'ThisWorkbook.Sheets(sheetName).Delete
'Application.DisplayAlerts = True
'ThisWorkbook.Save


ThisWorkbook.Sheets.Add(after:=Sheets(Sheets.Count)).Name = sheetName '添加sheet
tRow = ThisWorkbook.Sheets(sheetName).UsedRange.Rows.Count

AK14.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets(sheetName).Range("a" & tRow)



For i = 3 To rc - 2

If Trim(AK14.Sheets(1).Cells(i, cc).Text) = "NULL" Then
AK14.Sheets(1).Cells(i, cc) = 0
End If

If Trim(AK15.Sheets(1).Cells(i, cc).Text) = "NULL" Then
AK15.Sheets(1).Cells(i, cc) = 0
End If

If Trim(AK16.Sheets(1).Cells(i, cc).Text) = "NULL" Then
AK16.Sheets(1).Cells(i, cc) = 0
End If


ThisWorkbook.Sheets(sheetName).Cells(i, cc) = AK14.Sheets(1).Cells(i, cc) + AK15.Sheets(1).Cells(i, cc) + AK16.Sheets(1).Cells(i, cc)

If Left(myFile, 8) = "gn-ul-dl" Then

If Trim(AK14.Sheets(1).Cells(i, cc - 1).Text) = "NULL" Then
AK14.Sheets(1).Cells(i, cc - 1) = 0
End If

If Trim(AK15.Sheets(1).Cells(i, cc - 1).Text) = "NULL" Then
AK15.Sheets(1).Cells(i, cc - 1) = 0
End If

If Trim(AK16.Sheets(1).Cells(i, cc - 1).Text) = "NULL" Then
AK16.Sheets(1).Cells(i, cc - 1) = 0
End If

ThisWorkbook.Sheets(sheetName).Cells(i, cc - 1) = AK14.Sheets(1).Cells(i, cc - 1) + AK15.Sheets(1).Cells(i, cc - 1) + AK16.Sheets(1).Cells(i, cc - 1)
End If
Next



Workbooks(myFile14).Close False'關(guān)閉源工作簿,并不作修改
Workbooks(myFile15).Close False'關(guān)閉源工作簿,并不作修改
Workbooks(myFile16).Close False'關(guān)閉源工作簿,并不作修改

ThisWorkbook.Sheets(sheetName).Range("B3:Z" & (rc - 2)).Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("d2"), Order2:=xlAscending, Key3:=Range("c2"), Order3:=xlAscending

End If

myFile14 = Dir '找尋下一個(gè)*.xls文件
index = index + 1
Loop


Application.ScreenUpdating = True'凍結(jié)屏幕,此類語句一般成對使用

MsgBox "合并完成，請查看！", 64, "提示"
End Sub





Function FindName_new(ByRef what As String, ByRef currSheet As Worksheet) As String
Dim rng As Range
'Dim what As String
'what = "Error"
'Do
Set rng = currSheet.UsedRange.Find(what)
If Not rng Is Nothing Then

'Columns(rng.Column).Delete
'MsgBox "第一個(gè)數(shù)據(jù)發(fā)現(xiàn)在單元格:" & rng.address
FindName_new = rng.address(ReferenceStyle:=xlR1C1)
'sStr = ActiveCell.Address()
'Range(sStr).Offset(1, 0).Select
End If
'Loop
End Function

Function FindName(ByRef what As String, ByRef currSheet As Worksheet) As String
Dim rng As Range
'Dim what As String
'what = "Error"
'Do
Set rng = currSheet.UsedRange.Find(what)
If Not rng Is Nothing Then

'Columns(rng.Column).Delete
'MsgBox "第一個(gè)數(shù)據(jù)發(fā)現(xiàn)在單元格:" & rng.address
FindName = rng.address(ColumnAbsolute:=False)
'sStr = ActiveCell.Address()
'Range(sStr).Offset(1, 0).Select
End If
'Loop
End Function



Function statDevNum(ByRef currSheet As Worksheet) As Integer
Dim x As Integer, y As Integer, rc As Integer, cc As Integer, devCount As Integer, dateTime As String
Dim arr(1 To 10, 1 To 3)'創(chuàng)建一個(gè)可以容下10行3列的數(shù)組空間
Dim rng As Range

'最大行數(shù)、列數(shù)
rc = ActiveSheet.UsedRange.Rows.Count
cc = ActiveSheet.UsedRange.Columns.Count

'先判斷一天之內(nèi)有多少行記錄,即找出有多少個(gè)設(shè)備
dateTime = Cells(7, 2).Text
'MsgBox dateTime
devCount = 0
For x = 7 To rc
If dateTime = Cells(x, 2).Text Then
devCount = devCount + 1
Else
Exit For
End If
Next x

'MsgBox "devCount=" & devCount

statDevNum = devCount

End Function

Function SplitAddress(ByRef str As String, ByRef splitStr As String) As Integer '由查詢時(shí)間返回有效行數(shù)
Dim Val, n
'str = "資產(chǎn)分類-->硬件類-->整機(jī)-->個(gè)人處理設(shè)備-->筆記本-->中端筆記本"
Val = Split(str, splitStr)
'For n = LBound(Val) To UBound(Val)
'MsgBox Val(n)
'Next
SplitAddress = Val(UBound(Val))
End Function

Function SplitFileName(ByRef str As String, ByRef splitStr As String) As String '返回文件名
Dim Val, n
'str = "資產(chǎn)分類-->硬件類-->整機(jī)-->個(gè)人處理設(shè)備-->筆記本-->中端筆記本"
Val = Split(str, splitStr)
'For n = LBound(Val) To UBound(Val)
'MsgBox Val(n)
'Next
SplitFileName = Val(LBound(Val))
End Function


Sub 按鈕2_Click()
Sheets(1).UsedRange.Clear
End Sub

Sub 按鈕1_單擊()
Dim myPath$, myFile$, myTMP$, address$, kpiName$, TMP As Workbook, AK As Workbook, aRow%, tRow%, i%, j%, k%, r%, rc%, cc%, m%, devCount%, findCount%, index%
Dim arr(1 To 100, 1 To 1)'創(chuàng)建一個(gè)可以容下100行1列的數(shù)組空間，記錄計(jì)算結(jié)果

Application.ScreenUpdating = False'凍結(jié)屏幕，以防屏幕抖動(dòng)
'myPath = ThisWorkbook.Path & "\" '分表\" '把文件路徑定義給變量
myPath = getFilesPath
'myPath = "D:\000\EMS\test" '調(diào)試用
'myPath = "D:\000\EMS\20130419"

If myPath = "" Then
MsgBox "沒有選中文件夾，退出！"
Exit Sub'退出過程。
End If
myPath = myPath & "\"
'Exit Sub '退出過程。

'myFile = Dir(myPath & "*.xls")'依次找尋指定路徑中的*.xls文件
myFile = Dir(myPath & "*.csv")'依次找尋指定路徑中的*.xls文件

myTMP = "D:\kpi_name.xlsx"'打開指標(biāo)模板文件
Set TMP = Workbooks.Open(myTMP) '打開符合要求的文件
findCount = 0
index = 1'模板中sheet頁序列
tRow = ThisWorkbook.Sheets(1).UsedRange.Rows.Count

Do While myFile <> ""'當(dāng)指定路徑中有文件時(shí)進(jìn)行循環(huán)

If myFile <> ThisWorkbook.Name Then
'MsgBox myFile
Set AK = Workbooks.Open(myPath & myFile) '打開符合要求的文件

For i = 1 To 1 'AK.Sheets.Count '只對第一個(gè)工作本有效
aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row
'tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1
'tRow = ThisWorkbook.Sheets(1).UsedRange.Rows.Count + 3
tRow = tRow + 1
'AK.Sheets(i).Select
'AK.Sheets(i).Range("a3:k" & aRow).Copy ThisWorkbook.Sheets(1).Range("a" & tRow)


devCount = statDevNum(AK.Sheets(i)) '返回一天之內(nèi)的設(shè)備數(shù)
'MsgBox "devCount=" & devCount

'---------------------------------------------------------------------------------------------------------------
For index = 1 To TMP.Sheets.Count '遍歷模板頁
'遍歷打開工作頁的第六行，找到相應(yīng)的kpi name
findCount = 0
kpiName = ""'將kpiName變量置空，以免影響下一輪判斷
Erase arr'清空數(shù)組

For m = 1 To TMP.Sheets(index).UsedRange.Rows.Count
address = FindName_new(TMP.Sheets(index).Cells(m, 1).Value, AK.Sheets(i))

If address <> "" Then'找到了對應(yīng)的指標(biāo)列名 解析address

'MsgBox "address=" & address
j = SplitAddress(address, "C")
'MsgBox "column=" & SplitAddress(address, "C")
kpiName = TMP.Sheets(index).Cells(1, 1).Value

For k = 1 To (aRow - 6) / devCount'先填上日期再說，在B列
For r = 1 To devCount
arr(k, 1) = arr(k, 1) + AK.Sheets(i).Cells(6 + devCount * (k - 1) + r, j).Value
Next
Next
findCount = findCount + 1

End If
Next



'MsgBox "findCount=" & findCount
'MsgBox " TMP.Sheets(index).name=" & TMP.Sheets(index).Name
If kpiName <> "" Then
If findCount > 1 Or TMP.Sheets(index).UsedRange.Rows.Count = 2 Then
'ThisWorkbook.Sheets(1).Range("c" & tRow).Value = kpiName

'填上結(jié)果
For k = 1 To (aRow - 6) / devCount'先填上日期再說，在B列
'If arr(k, 1) > 0 Then
ThisWorkbook.Sheets(1).Cells(tRow + k, 1).Value = kpiName
'ThisWorkbook.Sheets(1).Cells(tRow + k, 2).Value = AK.Sheets(i).Cells(6 + devCount * (k - 1) + k, 2).Value
If devCount > 1 Then
ThisWorkbook.Sheets(1).Cells(tRow + k, 2).Value = AK.Sheets(i).Cells(6 + devCount * k - 1, 2).Value
Else
ThisWorkbook.Sheets(1).Cells(tRow + k, 2).Value = AK.Sheets(i).Cells(6 + k, 2).Value
End If

ThisWorkbook.Sheets(1).Cells(tRow + k, 3).Value = arr(k, 1)
ThisWorkbook.Sheets(1).Cells(tRow + k, 4).Value = "findCount:" & findCount
ThisWorkbook.Sheets(1).Cells(tRow + k, 5).Value = "devCount:" & devCount
ThisWorkbook.Sheets(1).Cells(tRow + k, 6).Value = myFile
'End If
Next

'tRow = tRow + k + 1 '添加之后行數(shù)重新計(jì)算
'tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 2
tRow = tRow + k + 1
End If
'tRow = ThisWorkbook.Sheets(1).UsedRange.Rows.Count + 3
End If

Next
'-------------------------------------------------------------------------------------------------------------------------------------------
Next
Workbooks(myFile).Close False'關(guān)閉源工作簿,并不作修改
End If

myFile = Dir '找尋下一個(gè)*.xls文件
Loop

Workbooks("kpi_name.xlsx").Close False'關(guān)閉源工作簿,并不作修改
Application.ScreenUpdating = True'凍結(jié)屏幕,此類語句一般成對使用
MsgBox "匯總完成，請查看！", 64, "提示"
End Sub