如何遍歷文件夾中的工作簿並取消合併單元格並填充它們

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