如何循环浏览文件夹中的工作簿并取消合并单元格并填充它们

Question

基本上我正在尝试检查文件夹中的工作簿（大约 12 个工作簿），这些工作簿中的一些工作表已合并单元格，我想取消合并并用最高值填充它们。以下是我尝试过的。

如果我将下面的代码用于单个工作簿，它就可以工作。

Sub Findmergedcellsandfill()


    Dim MergedCell As Range,
    Dim FirstAddress As String
    Dim MergeAddress As String
    Dim MergeValue As Variant

    Application.FindFormat.MergeCells = True

      Do

        Set MergedCell = ActiveSheet.UsedRange.Find("", LookAt:=xlPart, SearchFormat:=True)
        If MergedCell Is Nothing Then Exit Do
        MergeValue = MergedCell.Value
        MergeAddress = MergedCell.MergeArea.Address
        MergedCell.MergeArea.UnMerge
        Range(MergeAddress).Value = MergeValue
      Loop
      Application.FindFormat.Clear

End Sub

要检查所有工作簿并执行此代码，我尝试了以下方法，但实际上并没有做任何事情，如果有人可以帮助我，不胜感激。

Sub findandfilltheunmergedcells()

    Dim FolderPath As String    
    Dim WorkBk As Workbook
    Dim MergedCell As Range, FirstAddress As String, MergeAddress As String, MergeValue As Variant


    FolderPath = "C:\Users\docs\"


    FileName = Dir(FolderPath & "*.xl*")


    Do While FileName <> ""

        Set WorkBk = Workbooks.Open(FolderPath & FileName)

        Application.FindFormat.MergeCells = True


    Do

        Set MergedCell = ActiveSheet.UsedRange.Find("", LookAt:=xlPart, SearchFormat:=True)
            If MergedCell Is Nothing Then Exit Do
            MergeValue = MergedCell.Value
            MergeAddress = MergedCell.MergeArea.Address
            MergedCell.MergeArea.UnMerge
            Range(MergeAddress).Value = MergeValue
    Loop

        Application.FindFormat.Clear

    Loop

End Sub

Answer 1

当您合并一组单元格时，只会保留最上面的值。

打开您要处理的所有工作簿。然后运行 ​​UnMergeCellsOfAllOpenWorkbooks()

Sub UnMergeCellsOfAllOpenWorkbooks()
    Dim wb As Workbook
    Dim ws As Worksheet
    For Each wb In Workbooks
        For Each ws In wb.Worksheets
            ws.Cells.MergeCells = False
        Next
    Next
End Sub

Answer 2

我会遍历文件夹中的所有文件，打开每个文件，进行更改，在这种情况下取​​消合并单元格，然后保存更改并逐个关闭文件。

Sub Example()
    Dim MyPath As String, FilesInPath As String
    Dim MyFiles() As String, Fnum As Long
    Dim mybook As Workbook
    Dim CalcMode As Long
    Dim sh As Worksheet
    Dim ErrorYes As Boolean

    'Fill in the path\folder where the files are
    MyPath = "C:\Users\Ron\test"

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xl*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Loop through all files in the array(myFiles)
    If Fnum > 0 Then
        For Fnum = LBound(MyFiles) To UBound(MyFiles)
            Set mybook = Nothing
            On Error Resume Next
            Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
            On Error GoTo 0

            If Not mybook Is Nothing Then


                'Change cell value(s) in one worksheet in mybook
                On Error Resume Next
                With mybook.Worksheets(1)
                    sh.Cells.MergeCells = False
                End With


                If Err.Number > 0 Then
                    ErrorYes = True
                    Err.Clear
                    'Close mybook without saving
                    mybook.Close savechanges:=False
                Else
                    'Save and close mybook
                    mybook.Close savechanges:=True
                End If
                On Error GoTo 0
            Else
                'Not possible to open the workbook
                ErrorYes = True
            End If

        Next Fnum
    End If

    If ErrorYes = True Then
        MsgBox "There are problems in one or more files, possible problem:" _
             & vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
    End If

    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub