如何在我的工作簿中的每張紙上運行這個 VBA 代碼？

Question

我有一個 60 張工作簿，每張都有相同的格式。 我需要在每個單元格中合並一堆單元格，所以我有這段代碼可以做到這一點。 有沒有一種方法可以在整個文檔中運行它，而不必在每張紙上單獨運行它？

Sub MrgeColumns()
    Range("T3:T209").Merge
    Range("AU3:AU209").Merge
    Range("BT3:BT209").Merge
    Range("CS3:CS209").Merge
    Range("DS3:DS209").Merge
    Range("ET3:ET209").Merge
    Range("FT3:FT209").Merge
    Range("GR3:GR209").Merge
    Range("HP3:HP209").Merge
    Range("IN3:IN209").Merge
End Sub

Answer 1

給它一個工作表參數，然后你可以使用循環調用它。

Sub MergeAll()
  Dim ws as Worksheet
  For each ws in ActiveWorkbook.WorkSheets
    MrgeColumns ws
  Next
End Sub


Sub MrgeColumns(ws as Worksheet)
  With ws
    .Range("T3:T209").Merge
    .Range("AU3:AU209").Merge
    .Range("BT3:BT209").Merge
    .Range("CS3:CS209").Merge
    .Range("DS3:DS209").Merge
    .Range("ET3:ET209").Merge
    .Range("FT3:FT209").Merge
    .Range("GR3:GR209").Merge
    .Range("HP3:HP209").Merge
    .Range("IN3:IN209").Merge
  End With
End Sub

Answer 2

跨工作表合並列范圍

Option Explicit

' Merges the column ranges in all worksheets.
Sub TESTmergeColumnRanges()
    Const ColumnList As String = "T,AU,BT,CS,DS,ET,FT,GR,HP,IN"
    Const FirstRow As Long = 3
    Const LastRow As Long = 209
    mergeColumns ThisWorkbook, ColumnList, FirstRow, LastRow
End Sub

' Merges the column ranges in worksheets whose names are not
' in the Exceptions List.
Sub TESTmergeColumnRangesWithExceptions()
    Const ExceptionList As String = "Sheet2,Sheet4"
    Const ColumnList As String = "T,AU,BT,CS,DS,ET,FT,GR,HP,IN"
    Const FirstRow As Long = 3
    Const LastRow As Long = 209
    mergeColumns ThisWorkbook, ColumnList, FirstRow, LastRow, ExceptionList
End Sub

' Unmerges the column ranges in all worksheets.
Sub TESTunMergeColumnRanges()
    Const ColumnList As String = "T,AU,BT,CS,DS,ET,FT,GR,HP,IN"
    Const FirstRow As Long = 3
    Const LastRow As Long = 209
    mergeColumns ThisWorkbook, ColumnList, FirstRow, LastRow, , False
End Sub

Sub mergeColumns( _
        wb As Workbook, _
        ByVal ColumnList As String, _
        ByVal FirstRow As Long, _
        ByVal LastRow As Long, _
        Optional ByVal ExceptionList As String, _
        Optional ByVal doMerge As Boolean = True)
    Dim Cols() As String: Cols = Split(ColumnList, ",")
    Dim ws As Worksheet
    Dim n As Long
    If ExceptionList = "" Then
        For Each ws In wb.Worksheets
            mergeColumnsInWorksheet ws, Cols, FirstRow, LastRow, doMerge
        Next ws
    Else
        Dim Exceptions() As String: Exceptions = Split(ExceptionList, ",")
        For Each ws In wb.Worksheets
            If IsError(Application.Match(ws.Name, Exceptions, 0)) Then
                mergeColumnsInWorksheet ws, Cols, FirstRow, LastRow, doMerge
            End If
        Next ws
    End If
End Sub

Sub mergeColumnsInWorksheet( _
        ws As Worksheet, _
        Cols() As String, _
        ByVal FirstRow As Long, _
        ByVal LastRow As Long, _
        Optional ByVal doMerge As Boolean = True)
    Dim n As Long
    With ws.Rows(FirstRow & ":" & LastRow)
        If doMerge Then
            For n = 0 To UBound(Cols)
                .Columns(Cols(n)).Merge
            Next n
        Else
            For n = 0 To UBound(Cols)
                .Columns(Cols(n)).UnMerge
            Next n
        End If
    End With
End Sub