EXCEL程序

zhyicong

我的电脑WIN10  office2016  
EXCEL  设置了 宏程序 读取 WORD 信息和对应的页数。
目前运行后，页数信息出来了，但是物料信息没有获取。
请大神指引。 附件有对应的内容

Sub 读取word()
'禁止系统刷屏，触发其他事件等
    On Error Resume Next    '// 发生错误，自动执行下一句，就是忽略错误
    Application.ScreenUpdating = False '//关闭屏幕刷新
    Application.DisplayAlerts = False '//关闭系统提示
    Dim time_Start
    time_Start = Timer   '//开始时间
    Dim strFolder As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select File"
.InitialFileName = "d:\Users\Desktop\output\"  '//存放地址
If .Show Then
strFolder = .SelectedItems(1)
End If
End With

Dim i, ture, od, j, z, zz, mytable, x, k, c, mid, Format
   
i = 1
Dim ow As Object
Set ow = GetObject("word.application")
If ow Is Nothing Then
Set ow = CreateObject("word.application")
ow.Visible = ture
End If

Set od = ow.Documents.Open(Filename:=strFolder)
Set ow = Nothing
j = 1
z = 0
zz = 0
x = od.Tables.Count
For k = 1 To od.Tables.Count
Set mytable = od.Tables(k)

For Each c In mytable.Range.Cells
If InStr(c, "物料：42") > 0 Then
If InStr(c, "4203") > 0 Then
        Cells(i, 1) = mid(c, InStr(c, "4203"), 10)
         Else
         If InStr(c, "4202") > 0 Then
        Cells(i, 1) = mid(c, InStr(c, "4202"), 10)
        Else
         If InStr(c, "4212") > 0 Then
        Cells(i, 1) = mid(c, InStr(c, "4212"), 10)
        Else
         If InStr(c, "4210") > 0 Then
        Cells(i, 1) = mid(c, InStr(c, "4210"), 10)
        Else
        If InStr(c, "4207") > 0 Then
        Cells(i, 1) = mid(c, InStr(c, "4207"), 10)
     End If
     End If
     End If
         End If
End If



z = 1
Exit For
End If
Next
If z = 0 Then '判断是否发现新料码
j = j + 1
Else '发现新料码
'避免新料码上一页无表格
If (k - 1 <> 0) And (j > 1) Then
Set mytable = od.Tables(k - 1)
For Each c In mytable.Range.Cells
If InStr(c, "入库班组：") > 0 Then
zz = 1
End If
Next
If zz = 0 Then
j = j + 1
zz = 0
End If
End If
i = i + 1
If i - 2 <> 0 Then
Cells(i - 2, 2) = j
j = 1
End If
z = 0
End If
Next
Cells(i - 1, 2) = j
od.Close False
  Application.ScreenUpdating = True '//恢复屏幕刷新
    Application.DisplayAlerts = True '//恢复系统提示
       MsgBox "本次检索共用时：" & Format(Timer - time_Start, "#0.0000") & " 秒", , "新能源工程部提示"  '//提示所用时间
End Sub

yylucke

你把内部函数mid，在dim里定义了，怎么能得到值？

yylucke

1、去掉dim中的mid
2、你的那么多if可以修改为
    If InStr(c, "物料：42") > 0 Then
        Tmp = 0
        Tmp = InStr(c, "4203") Or InStr(c, "4202") Or InStr(c, "4212") Or InStr(c, "4210") Or InStr(c, "4207")
        If Tmp Then
            Cells(i, 1) = mid(c, Tmp, 10)
            z = 1
            Exit For
    End If

zhyicong

高手 你帮忙修改的程序，可以运行了
感谢大神，在请假另外一个异常 还请在出手下
目前就差这最后一步 不能 运行起到拆分PDF
Sub newPDF拆分()
On Error Resume Next
Dim n
Dim ok As Boolean
Dim PDFApp As Acrobat.AcroApp
Dim pddoc As Acrobat.AcroPDDoc
Dim tempPddoc As Acrobat.AcroPDDoc
Set PDFApp = CreateObject("AcroExch.App")
Set pddoc = CreateObject("AcroExch.PDDoc")
Set tempPddoc = CreateObject("AcroExch.PDDoc")
If Not tempPddoc.Open("d:\Users\Desktop\output\测试.pdf") Then
Set tempddoc = Nothing
Set PDFApp = Nothing
MsgBox Err.Number & ":" & Err.Description, vbOKOnly + vbCritical, "&#207;"
Exit Sub
End If
s = 0
'Call pddoc.insertPages(pddoc.GetNumPages() - 1, tempPddoc, 0, tempPddoc.GetNumPages(), False) '插入位置，数据来源文件，数据页码第一页为0，插入页数
'If x = pddoc.GetNumPages() Then
Arr = Sheet1.[a1].CurrentRegion   'a为原始数据存在第几列
For i = n To UBound(Arr)
ok = pddoc.Open("D:\output\" & Arr(i, 1) & ".pdf")
If ok <> -1 Then
ok = pddoc.Create()
End If
Call pddoc.insertPages(pddoc.GetNumPages() - 1, tempPddoc, s, Arr(i, 2), False)
s = s + Arr(i, 2)
ok = pddoc.save(1, "D:\output\" & Arr(i, 1) & ".pdf")
Call pddoc.Close
Next
tempPddoc.Close
PDFApp.Exit
Set tempPddoc = Nothing
Set PDFApp = Nothing
'Else
'MsgBox "有4202无表格"
'End If
End Sub

yylucke

建议修改为
sheet1.cells(i，1)=mid(c,tmp,10)
另，你的dim中把format去掉，这个是保留字，是内部函数。

zhyicong

yylucke 发表于 2020-3-4 10:40
建议修改为
sheet1.cells(i，1)=mid(c,tmp,10)
另，你的dim中把format去掉，这个是保留字，是内部函数。

上面的程序运行还是会存在
91：对象变量或WITH块变量未设置  的提示
求解

yylucke

兄嘚，你的代码怎么拼凑的啊？真的是漏洞太多。
比如：在过程：newPDF拆分()中，你dim n,后面循环用n作为i的起始值，然而你没有给n赋值。
比如：你的代码全是左对齐，看的头大
比如：你一开始用了n多的Set去定义设置对象，不知道你要做什么
建议：你整理基础表，写出你的需求，人工模拟出结果，重新发帖，比修改你的代码更快解决问题，你也能更快学习到解决问题的方法。