Word VBA(批量复制Excel表格和Word表格到Word中)
Function Test() '使用双字典
SearchPath = FolderDialog("请选择文件夹")
If SearchPath = "" Then
Exit Function
End If
WordName = SplitPath(CStr(SearchPath), 1)
Dim sFile As Object, fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set logFile = fso.CreateTextFile(SearchPath & WordName & "日志.txt", True)
Dim MyWord As Word.Application
Set MyWord = New Word.Application
MyWord.Application.ScreenUpdating = False
MyWord.Application.Visible = True
MyWord.Application.DisplayAlerts = wdAlertsNone
Set myDoc = MyWord.Documents.Add
With MyWord.ActiveDocument.PageSetup
.Orientation = wdOrientLandscape '纸张方向横向
End With
Dim CGType() As String '动态数组
ReDim Preserve CGType(7)
CGType(0) = "控制点"
CGType(1) = "界址点"
CGType(2) = "界址边长"
CGType(3) = "房角点"
CGType(4) = "房屋边长"
CGType(5) = "房屋面积"
CGType(6) = "巡查"
Dim ExcelApp As Object
If Tasks.Exists("Microsoft Excel") = True Then Tasks("Microsoft Excel").Close
Set ExcelApp = CreateObject("Excel.Application")
Dim wkBook As Object '代表excelworkbook（也就是excel工作簿文件 .xls .xlsx)
Dim wkSheet As Object '代表excel的工作页
ExcelApp.Application.EnableEvents = False '禁止宏等提示的运行
ExcelApp.Application.DisplayAlerts = False
ExcelApp.Application.CutCopyMode = False
Dim DicList, FileList, CunDic, I, FileName(), FilePath()
Dim excelPath As String
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
DicList.Add SearchPath, "" '初始化目录
'**************遍历一级目录 获取路径和村名*******************
Do While I < DicList.Count
Key = DicList.keys '本次要遍历的目录
NowDic = Dir(Key(I), vbDirectory) '开始查找
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(I) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录，则添加
If Not DicList.Exists(Key(I) & NowDic & "\") Then
DicList.Add Key(I) & NowDic & "\", NowDic
End If
End If
End If
NowDic = Dir() '再找
Loop
Exit Do
Loop
'****************************************************
'********************获取村所对应的文件夹和子文件夹********************************
Set CunDic = CreateObject("Scripting.Dictionary")
k = DicList.keys
v = DicList.Items
For I = 0 To DicList.Count - 1
If Not v(I) = "" Then
CunMin = v(I)
'加入村名 放在文件字典里
If Not FileList.Exists(CunMin) Then
FileList.Add CunMin, ""
End If
'FileList.RemoveAll
'*********************遍历村名下所有的文件夹*****************************
CunDic.RemoveAll
CunDic.Add k(I), ""
J = 0
Do While J < CunDic.Count
Key = CunDic.keys '本次要遍历的目录
NowDic = Dir(Key(J), vbDirectory)
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(J) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录，则添加
If Not CunDic.Exists(Key(J) & NowDic & "\") Then
CunDic.Add Key(J) & NowDic & "\", ""
End If
End If
End If
NowDic = Dir() '再找
Loop
J = J + 1
Loop
'***************************************************
'******************************在村名下对应的所有目录下搜索XLS文件*******************************
For Each Key In CunDic.keys '查找所有目录中的控制点文件
For m = 0 To UBound(CGType) - 1
If m <= UBound(CGType) - 2 Then
NowFile = Dir(Key & "*" & CGType(m) & "*.xls")
Else
NowFile = Dir(Key & "*" & CGType(m) & "*.docx")
End If
Do While NowFile <> ""
If Not FileList.Exists(CunMin) Then
FileList.Add CunMin, Key & NowFile 'FileList.Key=文件名,FileList.Item=目录
Else
If FileList.Item(CunMin) = "" Then
FileList(CunMin) = Key & NowFile
Else
FileList.Item(CunMin) = FileList.Item(CunMin) & "@" & Key & NowFile
End If
End If
NowFile = Dir()
Loop
Next
Next
End If
Next
'*********************************************************************************************
FileName() = FileList.keys
FilePath() = FileList.Items
For m = 0 To FileList.Count - 1
element = FileName(m)
excelPathArray = Split(FileList(element), "@")
'**********记录日志 7文件是否缺少文件******************************
For x = 0 To UBound(CGType) - 1
boolFind = False
For y = 0 To UBound(excelPathArray)
excelPath = excelPathArray(y)
If InStr(excelPath, CGType(x)) > 0 Then
boolFind = True
Exit For
End If
Next
If Not boolFind Then
logFile.WriteLine (element & "缺少" & CGType(x) & "成果")
End If
Next
'************************************************************************
For n = 0 To UBound(excelPathArray)
excelPath = excelPathArray(n)
extention = SplitPath(excelPath, 2)
If StrComp(extention, "xls", vbTextCompare) = 0 Then
Set wkBook = ExcelApp.Workbooks.Open(excelPath)
Set wkSheet = wkBook.Worksheets(1)
lastRowCount = ExcelApp.ActiveSheet.UsedRange.Rows.Count
lastColumnCount = ExcelApp.ActiveSheet.UsedRange.Columns.Count
lastEnColumnCount = ChgNumToABC(lastColumnCount)
excelrowcolumn = lastEnColumnCount & CStr(lastRowCount)
'Dim rng As Object
'Set rng = wkSheet.Range("A1:" & excelrowcolumn)
'rn.Copy
MyWord.Activate
With MyWord
If n = 0 Then
MyWord.Application.Selection.InsertBefore Text:=element
MyWord.Application.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel1
MyWord.Application.Selection.EndKey Unit:=wdLine, Extend:=wdMove
End If
wkSheet.Range("A1:" & excelrowcolumn).Copy
'myDoc.Paragraphs(1).Range.PasteExcelTable False, False, False '粘贴为表格
MyWord.Application.Selection.PasteExcelTable False, False, False
MyWord.Application.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText
If n <= UBound(excelPathArray) - 1 Then
MyWord.Application.Selection.EndKey Unit:=wdStory, Extend:=wdMove
MyWord.Application.Selection.Range.InsertAfter (vbCrLf)
'Else
'MyWord.Application.Selection.EndKey Unit:=wdStory, Extend:=wdMove
End If
ExcelApp.Application.Workbooks.Close
End With
'Set MyWord = Nothing
ElseIf StrComp(extention, "docx", vbTextCompare) = 0 Then
MyWord.Activate
Set otherDoc = MyWord.Documents.Open(excelPath)
otherDoc.Activate
MyWord.Application.Selection.WholeStory
MyWord.Application.Selection.Copy
myDoc.Activate
MyWord.Application.Selection.EndKey Unit:=wdLine, Extend:=wdMove
MyWord.Application.Selection.Paste
MyWord.Application.Selection.InsertBreak (wdPageBreak)
otherDoc.Close
End If
Next
Next
'*************************设置表格居中而非内容居中*************************
For Each tb In myDoc.Tables
tb.Rows.Alignment = wdAlignRowCenter
Next
'************************************************
MyWord.ActiveDocument.SaveAs FileName:=CStr(SearchPath) & WordName & ".doc"
MyWord.ActiveDocument.Close
MyWord.Application.ScreenUpdating = Ture
MyWord.Quit SaveChanges:=wdDoNotSaveChanges
ExcelApp.Application.CutCopyMode = False
logFile.Close
Set logFile = Nothing
Set fso = Nothing
ExcelApp.Application.Quit
Set CunDic = Nothing
Set FileList = Nothing
Set DicList = Nothing
Set DicList = Nothing
Set MyWord = Nothing
MsgBox "Done"
End Function
'ResultFlag=0 获取路径 'ResultFlag=1 获取文件名 'ResultFlag=2 获取扩展名
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "\")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
SplitPath = Left(FullPath, SplitPos - 1)
Case 1
If DotPos = 0 Then
If Right(FullPath, 1) = "\" Then
FullPath = Left(FullPath, Len(FullPath) - 1)
SplitPos = InStrRev(FullPath, "\")
End If
DotPos = Len(FullPath) + 1
End If
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
If DotPos = 0 Then DotPos = Len(FullPath)
SplitPath = Mid(FullPath, DotPos + 1)
Case Else
Err.Raise vbObjectError + 1, "SplitPath Function", "无效参数!"
End Select
End Function
Function FolderDialog(strTitle As String) As String '获取选择文件夹对话框的目录
Set objShell = CreateObject("Shell.Application")
Set objDialog = objShell.BrowseForFolder(0, strTitle, 0, 0)
If Not objDialog Is Nothing Then
If Right(objDialog.self.Path, 1) = "\\" Then
FolderDialog = objDialog.self.Path
Else
FolderDialog = objDialog.self.Path & "\"
End If
Else
FolderDialog = ""
MsgBox "没有选择文件夹"
End If
Set objDialog = Nothing
Set objShell = Nothing
End Function
'*****************************************************************************
'将Excel中列数转换为列名（如27列--->AA列）
'参数：var 列数
'返回：列名 string
'*****************************************************************************
Public Function ChgNumToABC(ByVal var As Integer) As String
Dim res As String
Dim remainder As Integer '余数
Dim quotient As Integer '商
remainder = var Mod 26
If remainder = 0 Then
var = var - 26
remainder = 26
End If
quotient = var \ 26
If quotient <> 0 Then
res = ChgNumToABC(quotient)
End If
ChgNumToABC = res & Chr(remainder + 65 - 1)
End Function
Function zhzm(num As Long) As String
Dim inum As Long
Dim imod As Long
Application.Volatile
Do While num
inum = IIf(num Mod 26 = 0, num \ 26 - 1, num \ 26)
imod = IIf(num Mod 26 = 0, 26, num Mod 26)
zhzm = Chr(64 + imod) & zhzm
num = inum
Loop
End Function
SearchPath = FolderDialog("请选择文件夹")
If SearchPath = "" Then
Exit Function
End If
WordName = SplitPath(CStr(SearchPath), 1)
Dim sFile As Object, fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set logFile = fso.CreateTextFile(SearchPath & WordName & "日志.txt", True)
Dim MyWord As Word.Application
Set MyWord = New Word.Application
MyWord.Application.ScreenUpdating = False
MyWord.Application.Visible = True
MyWord.Application.DisplayAlerts = wdAlertsNone
Set myDoc = MyWord.Documents.Add
With MyWord.ActiveDocument.PageSetup
.Orientation = wdOrientLandscape '纸张方向横向
End With
Dim CGType() As String '动态数组
ReDim Preserve CGType(7)
CGType(0) = "控制点"
CGType(1) = "界址点"
CGType(2) = "界址边长"
CGType(3) = "房角点"
CGType(4) = "房屋边长"
CGType(5) = "房屋面积"
CGType(6) = "巡查"
Dim ExcelApp As Object
If Tasks.Exists("Microsoft Excel") = True Then Tasks("Microsoft Excel").Close
Set ExcelApp = CreateObject("Excel.Application")
Dim wkBook As Object '代表excelworkbook（也就是excel工作簿文件 .xls .xlsx)
Dim wkSheet As Object '代表excel的工作页
ExcelApp.Application.EnableEvents = False '禁止宏等提示的运行
ExcelApp.Application.DisplayAlerts = False
ExcelApp.Application.CutCopyMode = False
Dim DicList, FileList, CunDic, I, FileName(), FilePath()
Dim excelPath As String
Set DicList = CreateObject("Scripting.Dictionary")
Set FileList = CreateObject("Scripting.Dictionary")
DicList.Add SearchPath, "" '初始化目录
'**************遍历一级目录 获取路径和村名*******************
Do While I < DicList.Count
Key = DicList.keys '本次要遍历的目录
NowDic = Dir(Key(I), vbDirectory) '开始查找
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(I) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录，则添加
If Not DicList.Exists(Key(I) & NowDic & "\") Then
DicList.Add Key(I) & NowDic & "\", NowDic
End If
End If
End If
NowDic = Dir() '再找
Loop
Exit Do
Loop
'****************************************************
'********************获取村所对应的文件夹和子文件夹********************************
Set CunDic = CreateObject("Scripting.Dictionary")
k = DicList.keys
v = DicList.Items
For I = 0 To DicList.Count - 1
If Not v(I) = "" Then
CunMin = v(I)
'加入村名 放在文件字典里
If Not FileList.Exists(CunMin) Then
FileList.Add CunMin, ""
End If
'FileList.RemoveAll
'*********************遍历村名下所有的文件夹*****************************
CunDic.RemoveAll
CunDic.Add k(I), ""
J = 0
Do While J < CunDic.Count
Key = CunDic.keys '本次要遍历的目录
NowDic = Dir(Key(J), vbDirectory)
Do While NowDic <> ""
If (NowDic <> ".") And (NowDic <> "..") Then
If (GetAttr(Key(J) & NowDic) And vbDirectory) = vbDirectory Then '找到子目录，则添加
If Not CunDic.Exists(Key(J) & NowDic & "\") Then
CunDic.Add Key(J) & NowDic & "\", ""
End If
End If
End If
NowDic = Dir() '再找
Loop
J = J + 1
Loop
'***************************************************
'******************************在村名下对应的所有目录下搜索XLS文件*******************************
For Each Key In CunDic.keys '查找所有目录中的控制点文件
For m = 0 To UBound(CGType) - 1
If m <= UBound(CGType) - 2 Then
NowFile = Dir(Key & "*" & CGType(m) & "*.xls")
Else
NowFile = Dir(Key & "*" & CGType(m) & "*.docx")
End If
Do While NowFile <> ""
If Not FileList.Exists(CunMin) Then
FileList.Add CunMin, Key & NowFile 'FileList.Key=文件名,FileList.Item=目录
Else
If FileList.Item(CunMin) = "" Then
FileList(CunMin) = Key & NowFile
Else
FileList.Item(CunMin) = FileList.Item(CunMin) & "@" & Key & NowFile
End If
End If
NowFile = Dir()
Loop
Next
Next
End If
Next
'*********************************************************************************************
FileName() = FileList.keys
FilePath() = FileList.Items
For m = 0 To FileList.Count - 1
element = FileName(m)
excelPathArray = Split(FileList(element), "@")
'**********记录日志 7文件是否缺少文件******************************
For x = 0 To UBound(CGType) - 1
boolFind = False
For y = 0 To UBound(excelPathArray)
excelPath = excelPathArray(y)
If InStr(excelPath, CGType(x)) > 0 Then
boolFind = True
Exit For
End If
Next
If Not boolFind Then
logFile.WriteLine (element & "缺少" & CGType(x) & "成果")
End If
Next
'************************************************************************
For n = 0 To UBound(excelPathArray)
excelPath = excelPathArray(n)
extention = SplitPath(excelPath, 2)
If StrComp(extention, "xls", vbTextCompare) = 0 Then
Set wkBook = ExcelApp.Workbooks.Open(excelPath)
Set wkSheet = wkBook.Worksheets(1)
lastRowCount = ExcelApp.ActiveSheet.UsedRange.Rows.Count
lastColumnCount = ExcelApp.ActiveSheet.UsedRange.Columns.Count
lastEnColumnCount = ChgNumToABC(lastColumnCount)
excelrowcolumn = lastEnColumnCount & CStr(lastRowCount)
'Dim rng As Object
'Set rng = wkSheet.Range("A1:" & excelrowcolumn)
'rn.Copy
MyWord.Activate
With MyWord
If n = 0 Then
MyWord.Application.Selection.InsertBefore Text:=element
MyWord.Application.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel1
MyWord.Application.Selection.EndKey Unit:=wdLine, Extend:=wdMove
End If
wkSheet.Range("A1:" & excelrowcolumn).Copy
'myDoc.Paragraphs(1).Range.PasteExcelTable False, False, False '粘贴为表格
MyWord.Application.Selection.PasteExcelTable False, False, False
MyWord.Application.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText
If n <= UBound(excelPathArray) - 1 Then
MyWord.Application.Selection.EndKey Unit:=wdStory, Extend:=wdMove
MyWord.Application.Selection.Range.InsertAfter (vbCrLf)
'Else
'MyWord.Application.Selection.EndKey Unit:=wdStory, Extend:=wdMove
End If
ExcelApp.Application.Workbooks.Close
End With
'Set MyWord = Nothing
ElseIf StrComp(extention, "docx", vbTextCompare) = 0 Then
MyWord.Activate
Set otherDoc = MyWord.Documents.Open(excelPath)
otherDoc.Activate
MyWord.Application.Selection.WholeStory
MyWord.Application.Selection.Copy
myDoc.Activate
MyWord.Application.Selection.EndKey Unit:=wdLine, Extend:=wdMove
MyWord.Application.Selection.Paste
MyWord.Application.Selection.InsertBreak (wdPageBreak)
otherDoc.Close
End If
Next
Next
'*************************设置表格居中而非内容居中*************************
For Each tb In myDoc.Tables
tb.Rows.Alignment = wdAlignRowCenter
Next
'************************************************
MyWord.ActiveDocument.SaveAs FileName:=CStr(SearchPath) & WordName & ".doc"
MyWord.ActiveDocument.Close
MyWord.Application.ScreenUpdating = Ture
MyWord.Quit SaveChanges:=wdDoNotSaveChanges
ExcelApp.Application.CutCopyMode = False
logFile.Close
Set logFile = Nothing
Set fso = Nothing
ExcelApp.Application.Quit
Set CunDic = Nothing
Set FileList = Nothing
Set DicList = Nothing
Set DicList = Nothing
Set MyWord = Nothing
MsgBox "Done"
End Function
'ResultFlag=0 获取路径 'ResultFlag=1 获取文件名 'ResultFlag=2 获取扩展名
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "\")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
SplitPath = Left(FullPath, SplitPos - 1)
Case 1
If DotPos = 0 Then
If Right(FullPath, 1) = "\" Then
FullPath = Left(FullPath, Len(FullPath) - 1)
SplitPos = InStrRev(FullPath, "\")
End If
DotPos = Len(FullPath) + 1
End If
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
If DotPos = 0 Then DotPos = Len(FullPath)
SplitPath = Mid(FullPath, DotPos + 1)
Case Else
Err.Raise vbObjectError + 1, "SplitPath Function", "无效参数!"
End Select
End Function
Function FolderDialog(strTitle As String) As String '获取选择文件夹对话框的目录
Set objShell = CreateObject("Shell.Application")
Set objDialog = objShell.BrowseForFolder(0, strTitle, 0, 0)
If Not objDialog Is Nothing Then
If Right(objDialog.self.Path, 1) = "\\" Then
FolderDialog = objDialog.self.Path
Else
FolderDialog = objDialog.self.Path & "\"
End If
Else
FolderDialog = ""
MsgBox "没有选择文件夹"
End If
Set objDialog = Nothing
Set objShell = Nothing
End Function
'*****************************************************************************
'将Excel中列数转换为列名（如27列--->AA列）
'参数：var 列数
'返回：列名 string
'*****************************************************************************
Public Function ChgNumToABC(ByVal var As Integer) As String
Dim res As String
Dim remainder As Integer '余数
Dim quotient As Integer '商
remainder = var Mod 26
If remainder = 0 Then
var = var - 26
remainder = 26
End If
quotient = var \ 26
If quotient <> 0 Then
res = ChgNumToABC(quotient)
End If
ChgNumToABC = res & Chr(remainder + 65 - 1)
End Function
Function zhzm(num As Long) As String
Dim inum As Long
Dim imod As Long
Application.Volatile
Do While num
inum = IIf(num Mod 26 = 0, num \ 26 - 1, num \ 26)
imod = IIf(num Mod 26 = 0, 26, num Mod 26)
zhzm = Chr(64 + imod) & zhzm
num = inum
Loop
End Function
