-计算机-每天学习一点专业知识
全部博文（21）
分类： WINDOWS
2018-09-21 17:52:35
Sub NDataCheck()
'获取E列的数据，并校验
end_row = Range("E65536").End(xlUp).Row 'E列数据最后行号
For i = 2 To end_row
'If Cells(i, "E").Interior.ColorIndex <> 43 Then
' Exit For
'End If
If Cells(i, "E") = "" Then
MsgBox Cells(i, "A") & "测试值为空"
ElseIf IsNumeric(Cells(i, "E")) Then
If Cells(i, "C") <= Cells(i, "E") And Cells(i, "E") <= Cells(i, "D") Then
Cells(i, "F") = "合格"
Else
Cells(i, "F") = "不合格"
End If
Else
MsgBox Cells(1, "E") & "测试值非数值"
End If
Next
End Sub
Sub DataStore()
'Word后期绑定
Dim wdapp As Object
Dim wdDoc As Object
Dim wdTable As Object
Set wdapp = CreateObject("word.application") '打开一个word运用环境
wdapp.Visible = False '允许word文件可见
Set wdDoc = wdapp.Documents.Open("D:\word\txt2.docx", Visible:=False)
Set wdTable = wdDoc.Tables(1) '选中第一个表格
With wdTable
For i = 2 To 6
.Cell(i, 5).Range.Text = Cells(i, "E")
Next
End With
'wdapp.Saved = True '将保存文档的Saved属性设置为True，这样后台运行的Word在保存文档时就不会弹出是否保存的对话框了，达到悄无声息的效果
wdDoc.Close True
'wdapp.ActiveDocument.SaveAs ("D:\word\导出数据.docx") '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称
wdapp.Application.Quit '退出并关闭程序文档
Set wdapp = Nothing '释放对象
End Sub
Sub DataStore1()
'Word后期绑定
Dim wdapp As Object
Dim wdDoc As Object
Dim wdTable As Object
Set wdapp = CreateObject("word.application") '打开一个word运用环境
wdapp.Visible = True '允许word文件可见
'Set wd = wdapp.Documents.Add '新建一个word文档
'Set tb = wd.Tables.Add(wd.Range(0, 0), 3, 6) '在文档开始处加入一个3行6列的表格！！
Dim strArray() As Variant, xlSheet As Worksheet, myDialog As FileDialog, oSel As Variant
Dim myArray(16) As String, r As Integer, i As Integer
On Error Resume Next
r = ActiveSheet.[a65536].End(xlUp).Row
'定义一个一维数组，给EXCEL数据表表头赋值
strArray = Array("姓名", "性别", "民族", "出生年月", "工作时间", "政治面貌及加入党派时间", "所在单位（部门）", "所在学科", "最高学位、取得时间及毕业学校", "最高学历、取得时间及毕业学校", "现任专业技术职务及取得时间", "现专业技术职务任职年限", "现从事专业及年限", "兼职研究生导师", "取得时间及受聘学校", "党政职务", "任职年限", "现聘岗位等级", "拟申报岗位类别", "拟申报岗位等级", "教师岗位类型", "拟聘方式", "符合条件明细（符合第X、X、X、…、项）", "备 注")
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 WORD 文件", "*.doc,*.docx", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = True '允许多项选择
If .Show = -1 Then '确定
Application.ScreenUpdating = False
For Each oSel In .SelectedItems '在所有选取word文档中循环
Set wdDoc = wdapp.Documents.Open(Filename:=oSel, Visible:=False)
For i = 1 To wdDoc.Tables.Count '在一个word文档的所有表格中循环
Set wdTable = wdDoc.Tables(i)
With wdTable '将word文档中指定的单元格内容赋值给数组
myArray(0) = Replace(.Cell(1, 2).Range.Text, Chr(13) & Chr(7), "")
myArray(1) = Replace(.Cell(1, 4).Range.Text, Chr(13) & Chr(7), "")
myArray(2) = Replace(.Cell(1, 6).Range.Text, Chr(13) & Chr(7), "")
myArray(3) = Replace(.Cell(1, 8).Range.Text, Chr(13) & Chr(7), "")
myArray(4) = Replace(.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
myArray(5) = Replace(.Cell(2, 4).Range.Text, Chr(13) & Chr(7), "")
myArray(6) = Replace(.Cell(2, 6).Range.Text, Chr(13) & Chr(7), "")
myArray(7) = Replace(.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")
myArray(8) = Replace(.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
myArray(9) = Replace(.Cell(3, 6).Range.Text, Chr(13) & Chr(7), "")
myArray(10) = Replace(.Cell(4, 2).Range.Text, Chr(13) & Chr(7), "")
myArray(11) = Replace(.Cell(4, 4).Range.Text, Chr(13) & Chr(7), "")
myArray(12) = Replace(.Cell(4, 6).Range.Text, Chr(13) & Chr(7), "")
myArray(13) = Replace(.Cell(5, 2).Range.Text, Chr(13) & Chr(7), "")
myArray(14) = Replace(.Cell(5, 4).Range.Text, Chr(13) & Chr(7), "")
myArray(15) = Replace(.Cell(6, 2).Range.Text, Chr(13) & Chr(7), "")
End With
r = r + 1 '变换行号
Sheets(1).Range(Cells(r, 1), Cells(r, 8)).Value = myArray '为单元格区域赋值
Next '完成一个文件的赋值
wdDoc.Close False
Next
With Sheets(1)
.Rows(1).Insert '插入表头行
.[A1:H1].Value = strArray
.UsedRange.Columns.AutoFit
End With
End If
End With
wdapp.Quit
Set wdapp = Nothing
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
Public gReportName As String
gReportRefName = ActiveWorkbook.Path & "\txt2.docx"
Sub DataStoreToExistedWord()
'Word后期绑定
Dim wdapp As Object
Dim wdDoc As Object
Dim wdTable As Object
Set wdapp = CreateObject("word.application") '打开一个word运用环境
wdapp.Visible = False '允许word文件可见
Set wdDoc = wdapp.Documents.Open("D:\word\txt2.docx", Visible:=False)
Set wdTable = wdDoc.Tables(1) '选中第一个表格
With wdTable
For i = 2 To 6
.Cell(i, 5).Range.Text = Cells(i, "E")
Next
End With
'wdapp.Saved = True '将保存文档的Saved属性设置为True，这样后台运行的Word在保存文档时就不会弹出是否保存的对话框了，达到悄无声息的效果
wdapp.ActiveDocument.SaveAs "D:\word\导出数据.docx" '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称
wdDoc.Close False
wdapp.Application.Quit '退出并关闭程序文档
Set wdapp = Nothing '释放对象
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'DataStoreToNewWordHighLev为最顶层函数，是每个表单《保存数据到新建文档》事件的响应函数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DataStoreToNewWord()
'根据当前表单的名字获取以下内容：
'1 在word中对应的表格编号
'2 测试数据的列号
'之后，将1、2作为参数，调用宏DataStoreToNewWordBased
End
End Sub
Sub DataStoreToNewWordBased(tblNum As Integer, wrColNum As Integer)
'Word后期绑定
Dim wdapp As Object
Dim wdDoc As Object
Dim wdTable As Object
Dim strCurTime As String
strCurTime = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) '获取当前时间，命名新建Word文档
Set wdapp = CreateObject("word.application") '打开一个word运用环境
wdapp.Visible = False '设置word不可见
Set wdDoc = wdapp.Documents.Open(Filename:=gReportRefName, Visible:=False, ReadOnly:=True)
Set wdTable = wdDoc.Tables(tblNum) '选中第一个表格
rStart = 2 '填写起始行号
rEnd = ActiveSheet.[65536,wrColNum].End(xlUp).Row '填写截止行号
With wdTable
For i = rStart To rEnd
.Cell(i, wrColNum).Range.Text = Cells(i, wrColNum)
Next
End With
wdDoc.SaveAs2 Filename:=ActiveWorkbook.Path & "\测试报告" & strCurTime & ".docx" '调用saveas命令保存文档，根据实际，指定文档的保存路径和名称
wdDoc.Close False '关闭文件不保存
wdapp.Application.Quit '退出并关闭程序文档
Set wdapp = Nothing '释放对象
Set wdDoc = Nothing '释放对象
Set wdTable = Nothing '释放对象
End Sub
