フォルダ内のワークブックをループしてセルのマージを解除してセルをマージする方法

Question

基本的にはフォルダ内のブック（約12個のブック）をチェックしようとしていますが、これらのブックの一部のシートは、それらを最上位の値で埋める。以下は私が試したことです。

以下のコードを1つのブックに使用すると動作します。誰かがそれで私を助けることができれば感謝し、

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 

すべてのブックをチェックして、このコードを実行するには、私は以下の方法を試してみましたが、doesntのは本当に何でもします。

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

セルのグループをマージすると、一番上の値だけが保持されます。

処理したいすべてのワークブックを開きます。次に、（）

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

私は、フォルダ内のすべてのファイルをループ、各オープン、変更になるだろうUnMergeCellsOfAllOpenWorkbooksを実行し、この場合には、その後、細胞を未マージの変更を保存して、一つ一つのファイルを閉じます。

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