Question

我有一个包含工作簿的文件夹，我试图将其合并到一个工作簿中，当它循环遍历工作簿时，我从“工作表”到“主”工作表收集了一些信息。除“主要”之外的每个工作表都包含以下表格：https://imgur.com/2kvZjNX。我需要将Root_cause和Solutions列中的所有值（在图像中以Text形式）文本连接起来，并将它们放在Main表的适当列中，它的外观应如下所示：https://imgur.com/rWJaC4W 因为存在以下情况：https://imgur.com/m0MQnXJ，其中Root_cause列可以包含合并的单元格，所以我提出了解决方案：

让我从1到100（因为root_cause / solutions表在表之间并没有那么大）
查找符号“№”，一旦找到-退出循环
创建空变量s（用于将Root_cause值连接到文本并将其放置在“ Main”表中的“ D”列中）和s1（用于文本连接）创建空变量s（用于“ Main”表中的“ E”列的解决方案值）） 4.）由于在某些情况下，Root_cause列存在合并的单元格（并且我假定VBA在循环时会将其余单元格视为空），因此我提出了以下条件：除非两列中的值均为空-否则继续存储值我收到438错误对象在此行上不支持此属性或方法：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

收到438错误的对象不支持此属性或方法

1 个答案: