【资料名称】：VBS数据核对

【资料作者】：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)'创建一个可以容下100行1列的数组空间，记录计算结果

Application.ScreenUpdating = False'冻结屏幕，以防屏幕抖动
'myPath = ThisWorkbook.Path & "\" '分表\" '把文件路径定义给变量
myPath = getFilesPath
'myPath = "D:\000\EMS\test" '调试用
'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 <> ""'当指定路径中有文件时进行循环

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

'最大行数、列数
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'关闭源工作簿,并不作修改
Workbooks(myFile15).Close False'关闭源工作簿,并不作修改
Workbooks(myFile16).Close False'关闭源工作簿,并不作修改

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 '找寻下一个*.xls文件
index = index + 1
Loop


Application.ScreenUpdating = True'冻结屏幕,此类语句一般成对使用

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 "第一个数据发现在单元格:" & 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 "第一个数据发现在单元格:" & 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)'创建一个可以容下10行3列的数组空间
Dim rng As Range

'最大行数、列数
rc = ActiveSheet.UsedRange.Rows.Count
cc = ActiveSheet.UsedRange.Columns.Count

'先判断一天之内有多少行记录,即找出有多少个设备
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 '由查询时间返回有效行数
Dim Val, n
'str = "资产分类-->硬件类-->整机-->个人处理设备-->笔记本-->中端笔记本"
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 = "资产分类-->硬件类-->整机-->个人处理设备-->笔记本-->中端笔记本"
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)'创建一个可以容下100行1列的数组空间，记录计算结果

Application.ScreenUpdating = False'冻结屏幕，以防屏幕抖动
'myPath = ThisWorkbook.Path & "\" '分表\" '把文件路径定义给变量
myPath = getFilesPath
'myPath = "D:\000\EMS\test" '调试用
'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"'打开指标模板文件
Set TMP = Workbooks.Open(myTMP) '打开符合要求的文件
findCount = 0
index = 1'模板中sheet页序列
tRow = ThisWorkbook.Sheets(1).UsedRange.Rows.Count

Do While myFile <> ""'当指定路径中有文件时进行循环

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

For i = 1 To 1 'AK.Sheets.Count '只对第一个工作本有效
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)) '返回一天之内的设备数
'MsgBox "devCount=" & devCount

'---------------------------------------------------------------------------------------------------------------
For index = 1 To TMP.Sheets.Count '遍历模板页
'遍历打开工作页的第六行，找到相应的kpi name
findCount = 0
kpiName = ""'将kpiName变量置空，以免影响下一轮判断
Erase arr'清空数组

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'找到了对应的指标列名 解析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

'填上结果
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 '添加之后行数重新计算
'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'关闭源工作簿,并不作修改
End If

myFile = Dir '找寻下一个*.xls文件
Loop

Workbooks("kpi_name.xlsx").Close False'关闭源工作簿,并不作修改
Application.ScreenUpdating = True'冻结屏幕,此类语句一般成对使用
MsgBox "汇总完成，请查看！", 64, "提示"
End Sub