利用Excel VBA实现数据自动抽取汇总（原创首发）

hellotwty

利用 Excel VBA 实现数据自动抽取汇总
作者：徐宝平    日期：2011年12月26日    公司：MTIW

前言：
对于电子工程师和测试工程师来说，最头疼的莫过于是整理测试了半天得到的数据，这些数据大部分是由软件自动测试生成并保存为.txt .log 等类似的文本格式。这些文本中的数据的分布的格式及文本的整体框架是一致的，这就为我们自动整理这些文本文件提供了条件。
下面我要介绍一款软件，它是基于Excel 和其中的VBA语言进行对文本格式的数据自动抽取和整理，并保存成我们自己定义的格式，前期介绍的是一维的格式数据整理，能将200多个文件的数据整理到一张sheet中。以便工程师分析和对比在不同条件下的前后数据的差异，从而找到问题的关键。
第一章        软件界面的介绍
这款软件的名称叫 标准相同格式文本整理-共享版.xls 之所以叫做共享版，是因为这是原软件的删改版，原软件是为我们公司特定的数据格式而编写的，能粗略的自动删改并对齐数据的格式，而这款软件只能对完全相同的数据格式的文本文件进行处理。如果大家有基本上格式相同的文本文件需要处理，可以发我，尽力修改成为您特制的数据整理软件。我的QQ ：751623467，加好友的时候注明 “数据整理”。不过我一般不怎么上线，那就发我邮箱吧！

......中间省略了 因为放不上图片！

第3章 源程序的讲解
为了让大家能充分使用和理解这款软件现将整个程序的代码附上，包含了相当充分的注释，相信只要是有心人，一定能打造属于自己的数据自动整理软件。

Private Declare Function apiOpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
Private Declare Function apiEmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long
Private Declare Function apiCloseClipboard Lib "user32" Alias "CloseClipboard" () As Long
Sub action_Click()
    Dim filetoopen(100) As String  '定义数组用于存放文件的路径 大小为100
    Dim filename(100) As String '用于存放文件名不包含后缀名
    Dim filenamesuffix(100) As String '用于存放文件名及后缀
    Dim intI As Integer '用于数组的循环
    Dim totalI As Integer '用于数组的大小
    Dim totallist As Integer '用于数组的大小
    Dim nextRow As String 'next row index
    Dim MyArray() As String '定义动态数组
    Dim arrayI As Integer '用于数组的大小 行
    Dim arrayJ As Integer '用于数组的大小 列
    'Dim fileSaveName1 As String  '用于存放文件名
    Dim xbp As String '临时用
    Dim softname As String '存放运行程序的文件名
    nextRow = 0
   
    softname = ActiveWorkbook.Name
    Windows(softname).Activate '将窗口提到 z-次序的最前面
    Worksheets("Sheet2").Activate   '激活sheet2
    ActiveSheet.UsedRange.Delete    '删除sheet2中已使用单元格中的数值
    Worksheets("Sheet1").Activate   '激活sheet1
   
    totallist = Application.WorksheetFunction.CountA(Range("B6:B1006")) '得到需要整理项的个数，最大为200项
    ReDim MyArray(totallist, 3)  '重新定义动态数组的大小及维数
        For arrayJ = 0 To 1
            For arrayI = 0 To totallist - 1
            MyArray(arrayI, arrayJ) = Worksheets("Sheet1").Range("C6").Offset(arrayI, arrayJ).Value
            Next arrayI
         Next arrayJ
   
        Range("B6", Range("B6").End(xlDown)).Select '选择B6及以下全部有值的单元格
        Selection.Copy
        Sheets("Sheet2").Select
        Range("A2").Select
        ActiveSheet.Paste
        Range("A1").Select
        ActiveCell.FormulaR1C1 = "S/N"
        Selection.HorizontalAlignment = xlCenter    '居中
        
        Sheets("Sheet1").Select
        Range("G9").Select
        totalI = Application.WorksheetFunction.CountA(Range("G9:G109")) '统计第7行第9列开始到结束的有值单元格格式
        MsgBox totalI & "个文件待处理...请确认"


        For intI = 0 To totalI - 1
            Windows(softname).Activate '将窗口提到 z-次序的最前面
            Sheets("Sheet1").Select
            filetoopen(intI) = Worksheets("Sheet1").Range("G9").Offset(nextRow, 0).Value '将文件及路径放到数组filetoopen中
            filename(intI) = Mid(filetoopen(intI), InStrRev(filetoopen(intI), "\", , vbTextCompare) + 1, _
                InStrRev(filetoopen(intI), ".", , vbTextCompare) - InStrRev(filetoopen(intI), "\", , vbTextCompare) - 1)
            filenamesuffix(intI) = Mid(filetoopen(intI), InStrRev(filetoopen(intI), "\", , vbTextCompare) + 1)
            nextRow = nextRow + 1
         Next intI
         
         nextRow = 0
         For intI = 0 To totalI - 1
            
            Workbooks.OpenText filename:=filetoopen(intI), Origin:=936, StartRow:=1 _
            , DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, Comma:=False, _
            Space:=True, Other:=True, OtherChar:=":", FieldInfo:=Array(Array(1, 1), _
            Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:=True  '打开待处理的文件

            Cells.Select    '选中打开的待处理文件中的所有单元格
            Selection.Copy  '复制选中内容
            Windows(softname).Activate '将窗口提到 z-次序的最前面
            Sheets("Sheet3").Select
            Range("A1").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Range("A1").Select
            Windows(filenamesuffix(intI)).Activate
            ActiveWindow.Close savechangs = fail '关闭活动的工作簿  不保存
            Call myClr  '清空剪切板 以释放内存
            
            Windows(softname).Activate '将窗口提到 z-次序的最前面
            
             '执行关键的汇总功能
            
            Sheets("Sheet3").Select
            For arrayI = 0 To totallist - 1 '从sheet3中指定位置（由数组的第1列决定）读出数据并放到数组的第3列
                MyArray(arrayI, 2) = Worksheets("Sheet3").Range(MyArray(arrayI, 0)).Value
            Next arrayI
            
            Sheets("Sheet2").Select
            For arrayI = 0 To totallist - 1 '将数组的第3列的数值放到sheet2的指定（由数组的第2列决定）位置
                Worksheets("Sheet2").Range(MyArray(arrayI, 1)).Offset(0, nextRow).Value = MyArray(arrayI, 2)
            Next arrayI
            Range("B1").Offset(0, nextRow).Value = filename(intI)
            
            
            nextRow = nextRow + 1
        Next intI
   
    Worksheets("Sheet3").Activate   '激活sheet3
    ActiveSheet.UsedRange.Delete    '删除sheet3中已使用单元格中的数值
    Worksheets("Sheet2").Activate   '激活sheet2
   
    '保存整理好的工作表
    filesavename = Application.GetSaveAsFilename(fileFilter:="Excel Files(*.xls), * .xl * ", FilterIndex:=1, Title:="另存为")
        If filesavename <> False Then
            Sheet2.Activate
            ActiveSheet.Copy
            'MsgBox filesavename '显示待存入的文件名及路径 调试用
            ActiveWorkbook.Close SaveChanges:=True, filename:=filesavename   '新表关闭
            Sheet2.Select
        End If
End Sub

Sub open_sourcefile_Click()

Dim nfile As String
Dim nfiletemp As String
Dim nextRow As String 'next row index
Dim Filter As String  '用于定义打开文件的类型
Dim filetoopen  '定义为数组，存放需要打开的文件名
Dim intI As Integer '用于数组的循环
Dim totalI As Integer '用于存储数组的大小
Dim lastI As Integer '用于文件名开始的位置在字符串中起始位置
nextRow = 0 '定义下次的偏移大小
totalI = 0

Filter = "All Files(*.*),*.*,Word Documents(*.do*),*.do*," & _
         "Text Files(*.txt),*.txt,Excel Files(*.xl*), * .xl * "

filetoopen = Application.GetOpenFilename(fileFilter:=Filter, FilterIndex:=1, Title:="请选择文件" _
    , MultiSelect:=True)

If Not IsArray(filetoopen) Then

    MsgBox "你没有选择文件", vbOKOnly, "提示"
    For intI = 1 To 200    '将E9向下的200个单元格内容清空
            Worksheets("Sheet1").Range("E9").Offset(nextRow, 0).Value = Null
            Worksheets("Sheet1").Range("G9").Offset(nextRow, 0).Value = Null
            nextRow = nextRow + 1
    Next intI
    nextRow = 0   '初始化偏移量
Else
    With Worksheets("Sheet1").Range("E9")
         For intI = 1 To 200    '将E9及G9向下的200个单元格内容清空
            .Offset(nextRow, 0).Value = Null
            .Offset(nextRow, 2).Value = Null
            nextRow = nextRow + 1
         Next intI
        nextRow = 0   '初始化偏移量
        totalI = UBound(filetoopen, 1) '得到FileToOpen中的一维数组的大小
        For intI = 1 To totalI
            nfile = filetoopen(intI)
            nfiletemp = Mid(nfile, InStrRev(nfile, "\", , vbTextCompare) + 1) '在包含文件路径的字符串中提取文件名
            .Offset(nextRow, 0).Value = nfiletemp
            .Offset(nextRow, 2).Value = nfile
            nextRow = nextRow + 1
        Next intI
    End With
   
End If

End Sub



Sub myClr()
    apiOpenClipboard (0) '打开剪切板
    apiEmptyClipboard '清空剪切板
    apiCloseClipboard '关闭剪切板
End Sub



【文件名】:111228@52RD_利用Excel VBA实现数据自动抽取汇总.pdf
【格　式】:pdf
【大　小】:664K
【简　介】:
【目　录】:
[UseMoney=1]

[/UseMoney]

mine

good LZ
本文来自：我爱研发网(52RD.com) - R&D大本营
详细出处：http://www.52rd.com/bbs/dispbbs.asp?boardid=89&id=230295&replyID=764899

gzliu15

good LZ!

sunnu789

我买，虽然不会用VBA。支持楼主，支持原创。

hellotwty

顶起啊！

hellotwty

想当初为了整理这那些实验数据熬了多少个晚，现在有了这个自动整理工具，5分钟就能搞定1-2小时才能完成的任务，没有白费我一周时间折腾出这个软件。
大家有什么不明白的地方，尽量跟贴出来，尽力解决，本着共同进步的愿望，希望能帮到苦于数据整理的朋友啊！
顺便挣点币啊，没有币的朋友到百度文库中也能搜到的。

awei1058

ding

billtest36

太好了 感謝分享 [em01]

chunhwa

谢谢提供这么好的东东。