VBA Excel中的应用程序错误 [英] Application Error in VBA Excel

问题描述

我有一个运行时错误'1004'：应用程序 - 我的代码定义或对象定义的错误。

  Sub  simpleXlsMerger（）
  Dim  bookList  As 工作簿
  Dim  mergeObj 作为 对象，dirObj 作为 对象，filesObj  As  对象，everyObj 作为 对象 
 Application.ScreenUpdating =  False  
 设置 mergeObj = CreateObject（  Scripting.FileSystemObject）
 
  Dim  strWSName 作为 字符串 
 strWSName = InputBox（ 输入要合并的Excel文件的文件路径）
 
 如果 strWSName<>   然后 
 < span class =code-comment>' 更改Excel文件的文件夹路径 
 设置 dirObj = mergeObj.GetFolder（strWSName）
 
 '  header  
范围（  A1）。Value =  项目 
范围（  B1）。值=  描述 
范围（   C1）。值=  质量 
 
 设置 fileObj = dirObj.Files 
 对于 每个 everyObj 在 fileObj 
 设置 bookList = Workbooks.Open（everyObj）
 
  Dim  rayong 作为 整数，苏州作为 < span class =code-keyword> Integer ，shenyang  as   Integer ，japan 作为 整数 
 rayong = InStr（ 1 ，everyObj，  RAYONG，vbTextCompare）
苏州= InStr（ 1 ，everyObj，  SZ，vbTextCompare）
 shenyang = InStr（ 1 ，everyObj， 沉阳，vbTextCompare）
 ' 注意：仍然不知道文件是否格式正确 
 japan = InStr（ 1 ，everyObj，  JPN，vbTextCompare）
 
 如果 rayong =  95  那么 
 ' 更改A2，此处包含每个文件的起始点的单元格引用 
 ' 例如B3：IV合并所有文件从列B和行3开始 
 ' 如果您使用的文件超过IV列，请将其更改为最新列 
 ' 同时将A65536上的A列更改为与起点相同的列 
范围（< span class =code-string>  A2：IV&范围（  A65536）。结束 （xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
 ' 请勿更改以下列。它与上面的列不同 
范围（  A65536）。 结束（xlUp）。偏移（ 1 ， 0 ）。PasteSpecial 
 
 ' 注意：应用程序错误??  
  ElseIf  suzhou =  100  然后 
 Workbooks.Open（everyObj）。激活
范围（  B2：B & Range（  A65536）。 End （xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（  A65536）。结束（xlUp）。偏移量（ 1 ， 0 ）。PasteSpecial 
 Workbooks.Open（everyObj）。激活
范围（  I2：I&范围（  A65536）。结束 （xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（   B65536）。结束（xlUp）.Offset（ 1 ， 0 ）。PasteSpecial 
 Workbooks.Open（everyObj）.Activate 
 Range（  H2：H& Range（  A65536）。结束（xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（  C65536）。 End （xlUp）.Offset（ 1 ， 0 ）。 PasteSpecial 
 
 ' 注意：应用程序错误??  
  ElseIf  shenyang =  95  然后 
 ActiveWorkbook .Sheets（  WMSInventory）。激活
范围（  A2：A&范围（  A65536）。结束 （xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（   A65536）。结束（xlUp）.Offset（ 1 ， 0 ）。PasteSpecial 
 ActiveWorkbook.Sheets（  WMSInventory）。激活
范围（  B2：B& Range（  A65536）。结束（xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（  B65536）。结束（ xlUp ）.Offset（ 1 ， 0 ）。PasteSpecial 
 ActiveWorkbook.Sheets（  WMSInventory）。激活
范围（  D2：D&范围（  A65536）。结束 （xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（   D65536）。结束（xlUp）.Offset（ 1 ， 0 ）。PasteSpecial 
 
 ' 注意：应用程序错误??  
  ElseIf  japan =  88  然后 
 Workbooks.Open（everyObj）。激活
范围（   A2：& Range（  A65536）。结束（xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（  A65536).结束（xlUp）.Offset（ 1 ， 0 ）。PasteSpecial 
 Workbooks.Open（everyObj）。激活
范围（  O2：O&范围（  A65536）。结束 （xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（   B65536）。结束（xlUp）.Offset（ 1 ， 0 ）。PasteSpecial 
 Workbooks.Open（everyObj）.Activate 
 Range（  B2：B& Range（  A65536）。结束（xlUp）.Row）。复制
 ThisWorkbook.Worksheets（ 1 ）。激活
范围（  C65536）。 End （xlUp）.Offset（ 1 ， 0 ）。 PasteSpecial 
 
 结束 如果 
 
 Application.CutCopyMode =  False  
 bookList.Close ' < ---- if条件后出现错误。 
 下一步 
 其他 
 MsgBox  没有FilePath提供！重新打开此excel以放置完整的文件路径。 
 结束 如果 
 结束  Sub  

请帮忙。:(

解决方案

基本上你在行上设置错误设置bookList = Workbooks.Open（everyObj）..

在集合fileObj中，您拥有所有类型的文件，甚至是隐藏的文件，这些文件可能是只读的并且尝试打开此类文件会导致错误，因此请更新解决方案以使用所需类型的文件填充集合仅

I have a run-time error '1004': Application - defined or object-defined error with my codes.

Sub simpleXlsMerger()
Dim bookList As Workbook
Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
Application.ScreenUpdating = False
Set mergeObj = CreateObject("Scripting.FileSystemObject")

Dim strWSName As String
strWSName = InputBox("Enter the file path of Excel Files to merge")

If strWSName <> "" Then
    'change folder path of excel files here
    Set dirObj = mergeObj.GetFolder(strWSName)
    
    'header
    Range("A1").Value = "Item"
    Range("B1").Value = "Description"
    Range("C1").Value = "Quality"
    
    Set fileObj = dirObj.Files
    For Each everyObj In fileObj
    Set bookList = Workbooks.Open(everyObj)
    
    Dim rayong As Integer, suzhou As Integer, shenyang As Integer, japan As Integer
    rayong = InStr(1, everyObj, "RAYONG", vbTextCompare)
    suzhou = InStr(1, everyObj, "SZ", vbTextCompare)
    shenyang = InStr(1, everyObj, "Shenyang", vbTextCompare)
    'Note: Still do not know if file has the right format
    japan = InStr(1, everyObj, "JPN", vbTextCompare)
    
    If rayong = 95 Then
    'change "A2" with cell reference of start point for every files here
    'for example "B3:IV" to merge all files start from columns B and row 3
    'If you're files using more than IV column, change it to the latest column
    'Also change "A" column on "A65536" to the same column as start point
    Range("A2:IV" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    'Do not change the following column. It's not the same column as above
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
    
    'Notes: Application Error??
    ElseIf suzhou = 100 Then
    Workbooks.Open(everyObj).Activate
    Range("B2:B" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
    Workbooks.Open(everyObj).Activate
    Range("I2:I" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial
    Workbooks.Open(everyObj).Activate
    Range("H2:H" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial
    
    'Notes: Application Error??
    ElseIf shenyang = 95 Then
    ActiveWorkbook.Sheets("WMSInventory").Activate
    Range("A2:A" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
    ActiveWorkbook.Sheets("WMSInventory").Activate
    Range("B2:B" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial
    ActiveWorkbook.Sheets("WMSInventory").Activate
    Range("D2:D" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("D65536").End(xlUp).Offset(1, 0).PasteSpecial
    
    'Notes: Application Error??
    ElseIf japan = 88 Then
    Workbooks.Open(everyObj).Activate
    Range("A2:A" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial
    Workbooks.Open(everyObj).Activate
    Range("O2:O" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial
    Workbooks.Open(everyObj).Activate
    Range("B2:B" & Range("A65536").End(xlUp).Row).Copy
    ThisWorkbook.Worksheets(1).Activate
    Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial
    
    End If
    
    Application.CutCopyMode = False
    bookList.Close '<---- Error appears here after an if condition.
    Next
Else
    MsgBox "No FilePath Provided! Re-Open this excel to put complete filepath."
End If
End Sub

Please help. :(

解决方案

Basically u r getting an error at line "Set bookList = Workbooks.Open(everyObj)" ..
In collection fileObj, you have got all sort of files, even the hidden ones which could be readonly and trying to open such files leads to error, so please update the solution to populate the collection with required type of files only.

这篇关于VBA Excel中的应用程序错误的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！