|
楼主 |
发表于 2022-6-8 22:08
|
显示全部楼层
本帖最后由 hasyh2008 于 2022-6-9 01:13 编辑
Sub 从WORD中导入数据()
On Error Resume Next
Application.ScreenUpdating = False '//关闭屏幕刷新
Application.DisplayAlerts = False '//关闭系统提示
Application.EnableEvents = False '//禁止触发其他事件
Application.StatusBar = False '关闭系统状态条
Dim F, X%, WD, Arr(), T As Single, Rs%
Dim Str1$, Str2$, Str3$, Str4$
T = Timer
F = Application.GetOpenFilename("Word文件,*.doc*", 1, MultiSelect:=True)
ReDim Arr(1 To UBound(F), 1 To 4)
For X = 1 To UBound(F)
Set WD = GetObject(F(X))
With WD.Tables(1)
Str1 = .Cell(1, 2).Range.Text
Str2 = .Cell(1, 4).Range.Text
Str3 = .Cell(1, 6).Range.Text
Str4 = .Cell(6, 6).Range.Text
Arr(X, 1) = VBA.Left(Str1, VBA.Len(Str1) - 2)
Arr(X, 2) = VBA.Left(Str2, VBA.Len(Str2) - 2)
Arr(X, 3) = Format(VBA.Left(Str3, VBA.Len(Str3) - 2), "0.00")
Arr(X, 4) = VBA.Left(Str4, VBA.Len(Str4) - 2)
WD.Close False
End With
With ActiveSheet
.Range("A1").CurrentRegion.Offset(1) = ""
.Range("A2").Resize(X, 4) = Arr
End With
Next X
Set WD = Nothing
MsgBox Format(Timer - T, "0.00")
Application.StatusBar = True '恢复系统状态条
Application.EnableEvents = True '//恢复触发其他事件
Application.ScreenUpdating = True '//恢复屏幕刷新
Application.DisplayAlerts = True '//恢复系统提示
End Sub
|
|