Word中表格操作

功能简介：将当前的Word表格换个格式保存

0.代码如下

---

' 复制文件，给Excel新增列
On Error Resume Next
Function changeStyle(folderspec)
	Dim fso, f, file, fc, s ,s1 ,s2 ,s3,ObjWD,ObjDOC
	Set fso = CreateObject("scripting.FileSystemObject")
	Set ObjWD=CreateObject("Word.application")
	Set f = fso.GetFolder(folderspec)
	Set fc = f.Files
	For Each file in fc
		If ( fso.getExtensionName(file.Path) = "doc" Or fso.getExtensionName(file.Path) = "docx" ) and instr(file.Path,"~") = 0 Then
			Set objDoc=ObjWD.Documents.Open(file.Path)
			Set objSelection = ObjWD.Selection
			
			
			' 选中最后一个表格
			set objTable=objDoc.Tables(objDoc.tables.Count)
			rowNum = objTable.Rows.Count 
			
			' 先新增再删除
			objSelection.EndKey 6
			ObjSelection.TypeParagraph
			
			ObjDOC.Tables.Add objSelection.Range, rowNum, 10
			
			
			Set objTable1 = ObjDOC.Tables(objDoc.tables.Count) 
			
			objTable1.AutoFitBehavior 2
			
			'*************表格样式
			objTable1.Range.Style = "网格型"
			
			
			
			' 合并单元格
			' 一、软件资料问题
			objSelection.MoveRight 1, 10, 1
			objSelection.Cells.Merge
			
			objSelection.MoveDown 5, 1
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objTable1.Cell(3, 1).Range.Select
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objSelection.MoveRight 1, 1
			objSelection.MoveRight 1, 2, 1
			objSelection.Cells.Merge
			
			objTable1.Cell(2, 1).Range.Select
			
			objSelection.MoveDown 5, 2
			objSelection.MoveRight 1, 10, 1
			objSelection.Cells.Merge
			
			'-------------------------
			objTable1.Cell(1, 1).Range.Font.Size = 12
			objTable1.Cell(1, 1).Range.Font.Bold = True
			
			objTable1.Cell(1, 1).Range.Text = "一、软件资料问题"
			objTable1.Cell(2, 1).Range.Text = "序号"
			objTable1.Cell(2, 2).Range.Text = "软件资料问题点"
			objTable1.Cell(2, 3).Range.Text = "整改建议"
			objTable1.Cell(2, 4).Range.Text = "整改期限"
			objTable1.Cell(2, 5).Range.Text = "整改依据"
			objTable1.Cell(2, 6).Range.Text = "备注"
			
			objTable1.Cell(4, 1).Range.Font.Size = 12
			objTable1.Cell(4, 1).Range.Font.Bold = True
			For i = 1 to 10
				objTable1.Cell(5, i).Range.Font.Size = 12
				objTable1.Cell(5, i).Range.Font.Bold = True
				if i <= 6 then
					objTable1.Cell(2, i).Range.Font.Size = 12
					objTable1.Cell(2, i).Range.Font.Bold = True
				end if
			Next
			
			objTable1.Cell(4, 1).Range.Text = "二、现场问题"
			objTable1.Cell(5, 1).Range.Text = "序号"
			objTable1.Cell(5, 2).Range.Text = "现场照片"
			objTable1.Cell(5, 3).Range.Text = "现场安全隐患"
			objTable1.Cell(5, 4).Range.Text = "整改意见"
			objTable1.Cell(5, 5).Range.Text = "整改期限"
			objTable1.Cell(5, 6).Range.Text = "整改依据"
			objTable1.Cell(5, 7).Range.Text = "依据原文"
			objTable1.Cell(5, 8).Range.Text = "隐患等级"
			objTable1.Cell(5, 9).Range.Text = "备注"
			objTable1.Cell(5, 10).Range.Text = "类别"

			
			ObjSelection.font.Size=10
			ObjSelection.font.Bold=False
			ObjSelection.font.name = "宋体"
			rowFlag = 0
			for i=1 to rowNum
				if instr(objTable.Cell(i, 1).Range.Text,"现场问题") > 0 then
					rowFlag = i
					exit for
				end if
			Next
			endNum = rowFlag - 1
			for i=3 to endNum
				for j = 1 to 6
					objTable1.Cell(i, j).Range.Font.Size = 10
					objTable1.Cell(i, j).Range.Font.Bold = False
					objTable1.Cell(i, j).Range.Cells.VerticalAlignment = 1 
				Next
				objTable1.Cell(i, 1).Range.Text = (i-2)
				objTable1.Cell(i, 2).Range.Text = objTable.Cell(i, 2).Range.Text 
				objTable1.Cell(i, 3).Range.Text = objTable.Cell(i, 3).Range.Text 
				objTable1.Cell(i, 4).Range.Text = "立即整改"
				objTable1.Cell(i, 5).Range.Text = objTable.Cell(i, 4).Range.Text 
				objTable1.Cell(i, 6).Range.Text = ""
			Next
			
			For i = 6 To rowNum
				For j = 1 To 10
					objTable1.Cell(i, j).Range.Font.Size = 10
					objTable1.Cell(i, j).Range.Font.Bold = False
					objTable1.Cell(i, j).Range.Cells.VerticalAlignment = 1 
					'objWorksheet.Range("K13").Select
					objTable1.Cell(i, 1).Range.Text = (i - 5) & "."
					objTable.Cell(i, 2).Range.Select
					objSelection.Copy 
					objTable1.Cell(i, 2).Range.Select
					objSelection.Paste 
					objTable1.Cell(i, 3).Range.Text = objTable.Cell(i, 3).Range.Text 
					objTable1.Cell(i, 4).Range.Text = replace(objTable.Cell(i, 4).Range.Text,"立即整改","") 
					objTable1.Cell(i, 5).Range.Text = "立即整改"
					objTable1.Cell(i, 6).Range.Text = objTable.Cell(i, 5).Range.Text 
					'objTable1.Cell(i, 1).Range.Value = objTable.Cell(i, 1).Range.Cells.Value
				Next
			Next
			objTable.Delete
		end if
		ObjDOC.SaveAs folderspec & "\Result\" & file.name
	Next
	objDoc.Close False
	ObjWD.Quit
End Function

path = InputBox("请输入要处理的目录","提醒","C:\Users\XXXX\Desktop\hhh\格式修改\Input")
changeStyle(path)