效果
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 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