6,210
社区成员
发帖
与我相关
我的任务
分享
Sub 表格转换()
Dim strInput As Variant
If Not Selection.Information(wdWithInTable) Then Exit Sub
strInput = InputBox("请输入工作簿名和工作表名,以中文逗号分隔")
If strInput = "" Then Exit Sub
Dim vName
vName = Split(strInput, ",")
Dim oTbl As Table
Dim iRows As Integer, iCols As Integer
Set oTbl = Selection.Tables(1)
iRows = oTbl.Rows.Count
iCols = oTbl.Columns.Count
Dim vTable
Dim i As Integer, j As Integer
ReDim vTable(iRows, iCols)
Dim str
For i = 1 To iRows
For j = 1 To iCols
str = oTbl.Cell(i, j)
vTable(i, j) = Left(oTbl.Cell(i, j), Len(str) - 1)
Next j
Next i
Dim xl As Object, wkb As Object, wks As Object
Set xl = VBA.CreateObject("Excel.Application")
Set wkb = xl.Workbooks.Add
Set wks = wkb.Worksheets(1)
xl.Visible = True
wks.Name = vName(1)
For i = 1 To iRows
For j = 1 To iCols
wks.Cells(i, j) = vTable(i, j)
Next j
Next i
Dim strFName As String
strFName = ActiveDocument.Path & "\" & vName(0) & ".xls"
xl.DisplayAlerts = False
wkb.SaveAs FileName:=strFName
Set xl = Nothing
End Sub
Dim strFName As String
If FileExists(vName(0) & ".xls") Then vName(0) = vName(0) & "副本"
strFName = ActiveDocument.Path & "\" & vName(0) & ".xls"
xl.DisplayAlerts = False
wkb.SaveAs FileName:=strFName
Set xl = Nothing
End Sub
Function FileExists(ByVal FileName As String) As Boolean
If Dir(FileName) <> "" Then
FileExists = True
Else
FileExists = False
End If
End Function
Dim strFName As String
If FileExists(vName(0)) Then vName(0) = vName(0) & "副本"
strFName = ActiveDocument.Path & "\" & vName(0) & ".xls"
ExcelSheet.SaveAs FileName:=strFName
'判断文件是否存在的函数
Function FileExists(ByVal FileName As String) As Boolean
On Error Resume Next
FileExists = Dir$(FileName) <> ""
If Err.Number <> 0 Then
FileExists = False
End If
On Error GoTo 0
End Function
Sub 表格转换()
Dim strInput As Variant
If Not Selection.Information(wdWithInTable) Then Exit Sub
strInput = InputBox("请输入工作簿名和工作表名,以中文逗号分隔")
If strInput = "" Then Exit Sub
Dim vName
vName = Split(strInput, ",")
Dim xl As Object, wkb As Object, wks As Object
Set xl = VBA.CreateObject("Excel.Application")
Set wkb = xl.Workbooks.Add
Set wks = wkb.Worksheets(1)
xl.Visible = True
wks.Name = vName(1)
Selection.Tables(1).Range.Copy
wks.PasteSpecial Format:="文本", Link:=False, DisplayAsIcon:=False
Dim strFName As String
strFName = ActiveDocument.Path & "\" & vName(0) & ".xls"
xl.DisplayAlerts = False
wkb.SaveAs FileName:=strFName
Set xl = Nothing
End Sub