汇总提取

 效果

Option Explicit
Sub extractAll()

Const namePos As String = "K44"     '名字第一个单元格的位置
Const processPos As String = "B8"   '过程第一个单元格的位置
Const contentPos As String = "B18"  '内容第一个单元格的位置
Const otherPos As String = "B38"    '其他第一个单元格的位置


Dim nameRowCount As Integer
Dim processRowCount As Integer
Dim contentRowCount As Integer
Dim otherRowCount As Integer
Dim realRowCount As Integer

Dim nameValue, processValue, contentValue, otherValue
Dim i As Integer
Dim j As Integer

Dim fileObject, fileFolder, files, file
Dim name
Set fileObject = CreateObject("Scripting.FileSystemObject")
Set fileFolder = fileObject.GetFolder("C:\Users\chaso\Desktop\test") 'Directory of excel files will be merge
Set files = fileFolder.files

Columns("A:Z").Clear

Range("A1:A2").Merge
Range("A1:A2").HorizontalAlignment = xlCenter
Range("A1:A2").VerticalAlignment = xlCenter
Range("A1") = "姓名"

Range("B1:G2").Merge
Range("B1:G2").HorizontalAlignment = xlCenter
Range("B1:G2").VerticalAlignment = xlCenter
Range("B1") = "过程"

Range("H1:M2").Merge
Range("H1:M2").HorizontalAlignment = xlCenter
Range("H1:M2").VerticalAlignment = xlCenter
Range("H1") = "内容"

Range("N1:S2").Merge
Range("N1:S2").HorizontalAlignment = xlCenter
Range("N1:S2").VerticalAlignment = xlCenter
Range("N1") = "其他"

i = 2
For Each file In files

If Right(file.name, 4) = "xlsx" Then
    Workbooks.Open (file.Path)
    nameValue = Workbooks(file.name).Sheets(1).Range(namePos).Value
    nameValue=Mid(nameValue, InStr(nameValue, "：") + 1, Len(nameValue))
    processValue = Workbooks(file.name).Sheets(1).Range(processPos).Value
    contentValue = Workbooks(file.name).Sheets(1).Range(contentPos).Value
    otherValue = Workbooks(file.name).Sheets(1).Range(otherPos).Value
    
    nameRowCount = 模块3.getRowCount(namePos)
    processRowCount = 模块3.getRowCount(processPos)
    contentRowCount = 模块3.getRowCount(contentPos)
    otherRowCount = 模块3.getRowCount(otherPos)
    realRowCount = Excel.Application.WorksheetFunction.Max(processRowCount, Excel.Application.WorksheetFunction.Max(contentRowCount, otherRowCount))
    
    
    Workbooks(1).Activate
    Workbooks(1).Sheets(1).Range("A" & CStr(i + 1) & ":A" & CStr(i + realRowCount)).Merge
    Workbooks(1).Sheets(1).Range("A" & CStr(i + 1)) = nameValue
    Workbooks(1).Sheets(1).Range("B" & CStr(i + 1) & ":G" & CStr(i + realRowCount)).Merge
    Workbooks(1).Sheets(1).Range("B" & CStr(i + 1)) = processValue
    Workbooks(1).Sheets(1).Range("H" & CStr(i + 1) & ":M" & CStr(i + realRowCount)).Merge
    Workbooks(1).Sheets(1).Range("H" & CStr(i + 1)) = contentValue
    Workbooks(1).Sheets(1).Range("N" & CStr(i + 1) & ":S" & CStr(i + realRowCount)).Merge
    Workbooks(1).Sheets(1).Range("N" & CStr(i + 1)) = otherValue
    i = i + realRowCount
    Workbooks(file.name).Close savechanges:=False
End If

Next

End Sub
 

模块3代码

Option Explicit

Function getRowCount(Pos As String) As Integer
    Dim iStr As String
    Dim iSpace As String
    With Range(Pos)
        iStr = Len(.Text)
        iSpace = Len(Replace(.Text, Chr(10), ""))
    End With
    'MsgBox "A1单元格中共" & iStr - iSpace & "个换行符"
    getRowCount = iStr - iSpace + 1
End Function