VBA批量提取word表格中的自我评分

Posted 2020-09-26 Excel VBA 小天地

　　单位里普遍存在各种低效率的办公行为，比如每年的自我评分。评分细目表为word文档，每行一个项目，每个项目要填写得分事项和分值，组长审核之后转成Excel向上递交。主要涉及到问题就是word文档中一列得分要转成Excel一行内容，如果一个人就复制，粘贴到Excel，再复制，转置即可。人一多，显得很麻烦。于是写了一段VBA来处理，在此保留备份。

　　

Sub 汇总个人评分()
    Dim FolderPath$, FileName$, FilePath$
    Dim wdApp As Object
    Dim Doc As Object
    Dim Tbl As Object
    Dim index&, iRow&, iCol&
    
    
    Cells.ClearContents
    
    Set wdApp = CreateObject("Word.Application")
    FolderPath = ThisWorkbook.Path & "\"
    FileName = Dir(FolderPath & "*.doc*")
    
    iRow = 0
    Do While FileName <> ""
        iRow = iRow + 1
        FilePath = FolderPath & FileName
        Set Doc = wdApp.documents.Open(FilePath)
        Set Tbl = Doc.Tables(1)
        
        Cells(iRow, 1).Value = WithNoSymbol(tb.Cell(1, 2).Range.Text)
        iCol = 1
        For index = 3 To 26
            iCol = iCol + 1
            Cells(iRow, iCol).Value = WithNoSymbol(tb.Cell(index, 5).Range.Text)
        Next index
        
        iCol = iCol + 1
        ‘Cells(iRow, iCol).Value = WithNoSymbol(tb.Cell(27, 9).Range.Text)
        Doc.Close
        FileName = Dir
    Loop
    wdApp.Quit
    Set wdApp = Nothing
    
End Sub
Function WithNoSymbol(ByVal OrgStr As String) As String
    WithNoSymbol = Left(OrgStr, Len(OrgStr) - 2)‘去除Word文档单元格后面加上两个符号
End Function