获取 438 错误对象不支持此属性或方法

Question

我有一个包含工作簿的文件夹，我试图将它们合并到一个工作簿中，当它在工作簿中循环时，我从工作表中收集了一些信息到“主”工作表。除“Main”外的每个工作表都包含这种表：https://imgur.com/2kvZjNX。我需要在 Root_cause 和 Solutions 列中加入所有值（在图像中写为文本），并将它们放在主表中的适当列中，它需要看起来像这样：https://imgur.com/rWJaC4W 因为有这样的情况：https://imgur.com/m0MQnXJ where Root_cause 列可以包含合并的单元格我想出了解决方案：

1. 让我们从 1 到 100 取 i （因为 root_cause/solutions 表没有得到那么大的工作表）

2. 寻找符号“№”，一旦找到 - 退出循环

3. 创建空变量 s（用于文本连接 Root_cause 值并将其放入“主”工作表中的“D”列）和 s1（用于文本连接“主”工作表中“E”列的解决方案值) 4.) 由于存在合并单元格的情况（并且我假设 VBA 在循环时将其余单元格视为空）对于 Root_cause 列，我设置了条件，除非两列中的值都为空 - 继续存储值 我收到 438 错误 Object does not support this property or method on this line: https://imgur.com/DIaWwCz 也许我的方法在概念上是错误的，我不知道......

这是我的代码：

Sub Merge()
    Path = "C:\Users\mdoskarin001\Desktop\SVOD2\"
    Filename = Dir(Path & "*xlsx")
    Do While Filename <> ""
        Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
        sDate = Workbooks(Filename).Sheets(1).Cells(7, 3).Value
        sTitle = Workbooks(Filename).Sheets(1).Cells(2, 3).Value

        For Each Workbook In Workbooks
            If Workbook.Name <> ThisWorkbook.Name Then
                Workbook.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
                ThisWorkbook.Sheets("Main").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = Filename
                ThisWorkbook.Sheets("Main").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = sTitle
                ThisWorkbook.Sheets("Main").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = sDate
                For i = 1 To 100
                    If Workbooks(Filename).Sheets(1).Cells(i, 1).Value = "№" Then
                        Exit For
                    End If
                Next i
                i = i + 1
                s = ""
                s1 = ""
                j = i
                Do
                    If Workbooks(Filename).Sheets(1).Cells(j, 2).Value <> "" Then
                        s = s + Workbooks(Filename).Sheets(1).Cells(j, 2).Value + vbCrLf
                    End If
                Loop While Workbooks(Filename).Cells(j, 2).Value <> "" Or Workbooks(Filename).Cells(j, 3).Value <> ""

                For j = 1 To 100

                    s = s + Workbooks(Filename).Sheets(1).Cells(j, 2).Value + vbCrLf
                    s1 = s1 + Workbooks(Filename).Sheets(1).Cells(j, 3).Value + vbCrLf
                Next j

                ThisWorkbook.Sheets("Main").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = s
                ThisWorkbook.Sheets("Main").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).Value = s1
            End If
        Next

        Set Workbook = Nothing
        Workbooks(Filename).Close savechanges:=False
        Filename = Dir()
    Loop         
End Sub

Answer 1

由于问题不清楚，因此假设仅基于图像中显示的数据。还假设每个文件只有第一张要合并

可以尝试根据您的要求修改代码

Sub Merge()
Dim Path As String, FileName As String, Wb As Workbook, Wm As Worksheet, Wt As Worksheet
Dim C As Range, MrgRw As Long, Sdate, STitle, SRoot, RwOff As Long, Txt As String
Dim lastRow As Long
Path = "C:\Users\user\Documents\Protocol\"
FileName = Dir(Path & "*xlsx")
Set Wm = ThisWorkbook.Sheets("Main")
lastRow = Wm.Range("A" & Rows.Count).End(xlUp).Row

    Do While FileName <> ""
    If FileName <> ThisWorkbook.Name Then
    Set Wb = Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)
    Wb.Worksheets(1).Copy After:=ThisWorkbook.Sheets(1)
    Wb.Close False
    Set Wt = ThisWorkbook.Sheets(2)
    Sdate = Wt.Cells(7, 3).Value
    STitle = Wt.Cells(2, 3).Value

    Set C = Wt.Range("A1:A100").Find(ChrW(&H2116), LookIn:=xlValues) '
    If Not C Is Nothing Then
    RwOff = 1
      Do While C.Offset(RwOff, 1).Value <> ""
      SRoot = C.Offset(RwOff, 1).Value
      lastRow = lastRow + 1
      MrgRw = C.Offset(RwOff, 1).MergeArea.Rows.Count
      Txt = ""
        For i = 0 To MrgRw - 1
        Txt = Txt & (i + 1) & "." & C.Offset(RwOff + i, 2).Value & vbCrLf
        Next
      Txt = IIf(Len(Txt) > 0, Left(Txt, Len(Txt) - 1), Txt)
      Wm.Range("A" & lastRow).Value = FileName
      Wm.Range("B" & lastRow).Value = STitle
      Wm.Range("C" & lastRow).Value = Sdate
      Wm.Range("D" & lastRow).Value = SRoot
      Wm.Range("E" & lastRow).Value = Txt
      RwOff = RwOff + MrgRw
      Loop
    End If

    FileName = Dir()
    End If
    Loop
End Sub