有关此代码的解释，请参阅答案的第一部分：https://stackoverflow.com/a/41036413/973283
包含 MergeandSplit 的模块
Option Explicit
Const RowHeightMax As Double = 409.5
Sub CalcRowHeights(ByRef CellHeights() As Double, ByRef RowHeights() As Double)
' On entry:
' * CellHeights has dimensions (1 to N) where N is the last column of a row
' containing a value. It contains the height of cells 1 to N. Cells
' within that range having no value or with WrapText=False are recorded as
' having a height of 0. For cells with a value and WrapText=False, the
' value recorded is the height of the cell necessary to view all its
' content even if that height is above the maximum for a row.
' On exit:
' * if none of the cells has a height more than the maximum for a row,
' RowHeights will have dimensions (1 to 1) and the value of the single
' entry will be the largest height of an of the cells.
' * If one or more cells has a height more than the maximum for a row,
' RowHeights will have dimensions (1 to M) where M is the number of rows
' necessary for the content of all cells to be visible. The values of the
' M entries will be the heights of the rows necessary to show the cell
' contents to best advantage.
Dim CellHeightMinAboveZero As Double
Dim CellHeightMax As Double
Dim CellHeightsRemaining() As Double
Dim InxCCrnt As Long
Dim InxRCrnt As Long
Dim RowHeightRemaining As Long
CellHeightMax = 0#
CellHeightMinAboveZero = 0#
' Find cell with largest height
For InxCCrnt = 1 To UBound(CellHeights)
If CellHeightMax < CellHeights(InxCCrnt) Then
CellHeightMax = CellHeights(InxCCrnt)
End If
Next
ReDim RowHeights(1 To 1) ' Will always need at least one entry
If CellHeightMax <= RowHeightMax Then
' All cell content will be visible within one row
RowHeights(1) = CellHeightMax
Exit Sub
End If
' Not all cell content can be visible in single row
' Copy caller's cell heights to working array and
' find minimum non-zero height. Already have maximum.
CellHeightMinAboveZero = 0#
ReDim CellHeightsRemaining(1 To UBound(CellHeights))
For InxCCrnt = 1 To UBound(CellHeights)
CellHeightsRemaining(InxCCrnt) = CellHeights(InxCCrnt)
If CellHeightsRemaining(InxCCrnt) > 0 Then
' This cell height > 0
If CellHeightMinAboveZero = 0 Or _
CellHeightMinAboveZero > CellHeightsRemaining(InxCCrnt) Then
' This cell height first non-zero height or less than previous minimum
CellHeightMinAboveZero = CellHeightsRemaining(InxCCrnt)
'InxCMin = InxCCrnt
End If
End If
Next
InxRCrnt = 0 ' No entries in RowHeights() yet
Do While True
If CellHeightMinAboveZero = CellHeightMax Then
' There is one or more cell with the maximum height.
' There are no cells with any other height
Call CalcRowHeightsAllocate(CellHeightMax, InxRCrnt, RowHeights)
Exit Sub
End If
' Allocate a row or rows for the smallest cell or cells or what
' remains unallocated of the smaller cell or cells
Call CalcRowHeightsAllocate(CellHeightMinAboveZero, InxRCrnt, RowHeights)
' Reduce values in CellHeightsRemaining
For InxCCrnt = 1 To UBound(CellHeights)
If CellHeightsRemaining(InxCCrnt) <> 0 Then
CellHeightsRemaining(InxCCrnt) = CellHeightsRemaining(InxCCrnt) - _
CellHeightMinAboveZero
End If
Next
' Find new maximum and minimum
CellHeightMax = 0#
CellHeightMinAboveZero = 0#
For InxCCrnt = 1 To UBound(CellHeights)
If CellHeightMax < CellHeightsRemaining(InxCCrnt) Then
CellHeightMax = CellHeightsRemaining(InxCCrnt)
End If
If CellHeightsRemaining(InxCCrnt) > 0 Then
' This cell height > 0
If CellHeightMinAboveZero = 0 Or _
CellHeightMinAboveZero > CellHeightsRemaining(InxCCrnt) Then
' This cell height first non-zero height or less than previous minimum
CellHeightMinAboveZero = CellHeightsRemaining(InxCCrnt)
End If
End If
Next
Loop
End Sub
Sub CalcRowHeightsAllocate(ByVal HeightToAllocate As Double, _
ByRef InxRCrnt As Long, _
ByRef RowHeights() As Double)
' Add rows to RowHeights to give a total height of HeightToAllocate
' If InxRCrnt = 0, RowHeights() has already been dimensioned as (1 To 1)
' but entry 1 is unused.
' If InxRCrnt > 0, RowHeights() has been dimensioned as (1 To InxRCrnt)
' with entries 1 To InxRCrnt unused. A new entry must be added.
' In either case, InxRCrnt is stepped to reflect new state of entries.
Dim NumRows As Long
InxRCrnt = InxRCrnt + 1
If InxRCrnt > 1 Then
' At least one new entry will be required.
ReDim Preserve RowHeights(1 To InxRCrnt)
End If
If HeightToAllocate <= RowHeightMax Then
' The height to allocate is less than the row maximum
RowHeights(InxRCrnt) = HeightToAllocate
Exit Sub
End If
NumRows = Fix((HeightToAllocate + RowHeightMax - 1) / RowHeightMax)
' Make row heights as close to equal as possible
' 1 pixel = 0.75 points. Height must be interger number of pixels
' Enlarge RowHeights for the extra rows
ReDim Preserve RowHeights(1 To InxRCrnt + NumRows - 1)
' Calculate preferred row height and allocate to first new row
RowHeights(InxRCrnt) = (HeightToAllocate * 4# / 3# / CDbl(NumRows)) * 0.75
' Reduce HeightToAllocate for height allocated
HeightToAllocate = HeightToAllocate - RowHeights(InxRCrnt)
' Set remaining new rows, except the last, to the same height as the first mew row
For InxRCrnt = InxRCrnt + 1 To UBound(RowHeights) - 1
RowHeights(InxRCrnt) = RowHeights(InxRCrnt - 1)
HeightToAllocate = HeightToAllocate - RowHeights(1)
Next
' Set last row to remaining height to allow for previous rows not
' being the exact, preferred fraction of toal height to allocate
RowHeights(UBound(RowHeights)) = HeightToAllocate
End Sub
Function CellHeightMerged(ByVal Wsht As Worksheet, ByVal RowTop As Long, _
ByVal ColLeft As Long, ByVal RowBot As Long, _
ByVal ColRight As Long, ByRef RowTest As Long, _
ByRef ColTest As Long) As Double
' * Wsht.Cells(RowTop, ColLeft) is the top left cell of an merged cell
' with RowBot and ColRight specifying the bottom right cell.
' * There is no code that would handle RowTop <> RowBot.
' * Wsht.Cells(RowTest, ColTest) is a cell below and to the right of any
' used cells.
' * The routine will use Wsht.Cells(RowTest, ColTest) and, if necessary
' cells below it, to determine the full height of the cell
Dim ColCrnt As Long
Dim WidthCombinedPixels As Long
Dim WidthCombinedPoints As Single
' Calculate combined width of columns within merged cell.
' Excel VBA sets and returns column widths in points but the calculate must be
' in pixels
With Wsht
WidthCombinedPixels = 0#
' Calculate total width of merged cells in pixels
For ColCrnt = ColLeft To ColRight
WidthCombinedPixels = WidthCombinedPixels + _
WidthPixelsFromPoints(.Cells(RowTop, ColCrnt).ColumnWidth)
Next
WidthCombinedPixels = WidthCombinedPixels + ColRight - ColLeft - 1 ' Allow for interior borders
' Set width of test column to total width of merged cells
.Columns(ColTest).ColumnWidth = WidthPointsFromPixels(WidthCombinedPixels)
' Copy contents of merged cell to test cell
.Cells(RowTop, ColLeft).Copy Destination:=.Cells(RowTest, ColTest)
' Use CellHeightUnmerged to determine height of test cell
CellHeightMerged = CellHeightUnmerged(Wsht, RowTest, ColTest, RowTest + 1, ColTest)
End With
End Function
Function CellHeightUnmerged(ByVal Wsht As Worksheet, ByVal RowCrnt As Long, _
ByVal ColCrnt As Long, ByRef RowTest As Long, _
ByRef ColTest As Long) As Double
' * Wsht.Cells(RowCrnt, ColCrnt) is an unmerged cell.
' * Wsht.Cells(RowTest, ColTest) is a cell below and to the right of any
' used cells.
' * The routine will use Wsht.Cells(RowTest, ColTest) and, if necessary
' cells below it, to determine the full height of the cell
' If a cell height exceeds the maximum row height, the cell content is split
' into parts so their total height can be calculated. For this to give the
' exact height, the separate parts must be split on a line boundary and must
' be formatted as the original. Unfortunately, when a cell is split, all the
' in-cell formatting is lost. It is possible to determine the formatting of
' the original cell and to apply that as approprite to the parts but this has
' proved to be impossibly slow. A multiplier applied to the height of a
' cell part is a crude technique but it gives good results with test data. It
' may (probably will) be necessary to experiment with the multiplier's value
' to get a statisfactory effect.
Const Multiplier As Double = 1.08
Dim AllRowHeightsBelowMaximum As Boolean
Dim CellHeightTotal As Double
Dim InCellFmts As New Collection
Dim InxIcf As Long
Dim LenCopy As Long
Dim PosStart As Long
Dim RowHeightCrnt As Double
Dim RowNumCrnt As Long
Dim RowNumMax As Long
Dim RowTemp As Long
Dim Text As String
With Wsht
If .Cells(RowCrnt, ColCrnt).Value = "" Then
CellHeightUnmerged = 0#
Exit Function
End If
.Columns(ColTest).ColumnWidth = .Columns(ColCrnt).ColumnWidth
.Cells(RowCrnt, ColCrnt).Copy Destination:=.Cells(RowTest, ColTest)
With .Cells(RowTest, ColTest)
.WrapText = True
.EntireRow.AutoFit
CellHeightTotal = .RowHeight
End With
If CellHeightTotal = RowHeightMax Then
' Text does not fit into single row at current width
' Split text of cell into as many parts as necessary for each part to
' give a cell height less than the maximum. This is a crude split but it
' is not obvious that a better split would give better results.
RowNumMax = 2
' Clear all formatting from test cells then set wrap
With .Cells(RowTest, ColTest)
.Clear
.WrapText = True
End With
With .Cells(RowTest + 1, ColTest)
.Clear
.WrapText = True
End With
PosStart = 1
Text = .Cells(RowCrnt, ColCrnt).Value
LenCopy = Len(Text) \ RowNumMax
Do While True ' Loop until row heights are all less than maximum
' Split text of cell into RowNumMax parts. This is a crude split but it
' is not obvious that a better split would give better results.
RowTemp = RowTest
For RowNumCrnt = 1 To RowNumMax - 1
' Copy early parts of text
.Cells(RowTemp, ColTest).Value = Mid(Text, PosStart, LenCopy)
PosStart = PosStart + LenCopy
RowTemp = RowTemp + 1
Next
' Copy last part of text
.Cells(RowTemp, ColTest).Value = Mid(Text, PosStart)
' Calculate total height of cell is all parts below maximum
CellHeightTotal = 0#
AllRowHeightsBelowMaximum = True
For RowTemp = RowTest To RowTest + RowNumMax - 1
.Rows(RowTemp).AutoFit
RowHeightCrnt = .Rows(RowTemp).RowHeight * Multiplier
If RowHeightCrnt < RowHeightMax Then
CellHeightTotal = CellHeightTotal + RowHeightCrnt
Else
AllRowHeightsBelowMaximum = False
Exit For
End If
Next
If AllRowHeightsBelowMaximum Then
Exit Do
End If
' RowNumMax was not enough rows to show entire text from cell
With .Cells(RowTest + RowNumMax, ColTest) ' Prepare another test cell
.Clear
.WrapText = True
End With
RowNumMax = RowNumMax + 1
Loop
End If
End With
CellHeightUnmerged = CellHeightTotal
End Function
Sub MergedandSplit()
' * This routine looks for cells whose row height is the maximum allowed
' indicating that not all the text within the cell will be visible.
' * If a row contains such cells, a row is inserted under it and the
' partially visible cells merged with the cell below it and the height of the two
' rows set so all the text is visible.
' * The previous sentence said "a row is inserted" and this is normally
' true. However, if a cell contains so much text that two full size rows
' are not enough to make it all visible, then as many rows as necessary
' are inserted.
Dim CellHeightCrnt As Double
Dim CellHeights() As Double
Dim ColCrnt As Long
Dim ColLastRowCrnt As Long
Dim ColLastWsht As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim InxM As Long
Dim InxR As Long
Dim MultiRowCellWithinRow As Boolean
Dim OpenMultirowCells As New Collection
Dim Rng As Range
Dim RowCrnt As Long
Dim RowHeightCrnt As Double
Dim RowHeights() As Double
Dim RowBot As Long
Dim RowLast As Long
Dim RowTemp As Long
Dim RowTop As Long
Dim Wsht As Worksheet
Call WidthPrepPixelsPoints ' Load arrays for pixel to point conversions
Set Wsht = Worksheets("Data")
With Wsht
' Find last row and column of worksheet
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
' The worksheet is empty
Debug.Assert False
' Add code as necessary to tell user
Exit Sub
End If
RowLast = Rng.Row
' No need to check worksheet is not empty since already know it isn't
ColLastWsht = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
' Is is not possible to use "For RowCrnt = 1 To RowLast" becuase inserted
' rows would increase RowLast and the end value of a For loop cannot change
' during the loop.
' "For RowCrnt = RowLast To 1 Step -1" would avoid the inserted row problem
' but it is necessary to move down the worksheet so as to detect and
' process multi-row cells correctly.
RowCrnt = 1
Do While RowCrnt <= RowLast
MultiRowCellWithinRow = False
If Not .Rows(RowCrnt).Hidden Then
ColLastRowCrnt = .Cells(RowCrnt, .Columns.Count).End(xlToLeft).Column
Debug.Print "Row " & RowCrnt & "'s last column " & ColLastRowCrnt
If ColLastRowCrnt <> 1 Or .Cells(RowCrnt, 1).Value <> "" Then
' This row contains at least one cell with a value
' End(xlToLeft).Column will not recognise a cell of a multi-row
' merged cell as containing a value unless it is the top left cell.
' If a multi-row merged cell is in the middle of the row, this does
' not matter because it will be detected as each column is examined.
' However, if a multi-row merged cell is to the right of any cells
' with values it will missed. If OpenMultirowCells is not empty,
' there is a multi-row merged cell that includes this row
If OpenMultirowCells.Count > 0 Then
MultiRowCellWithinRow = True
End If
ReDim CellHeights(1 To ColLastRowCrnt)
' Merged cells will always columns N, N+1, N+2 and so on making it
' easier to manage with increasing ColCrnt. However, stepping over
' a merged cell would not be possible with a For Loop so a Do
' Loop is necessary.
ColCrnt = 1
Do While ColCrnt <= ColLastRowCrnt
With .Cells(RowCrnt, ColCrnt)
If .Value <> "" And .WrapText Then
' Cell has value and row height is to increase, if necessary, so
' the entire the value is visible.
If .MergeCells Then
' Cell is part of merged area
Debug.Print "Cell " & Replace(.Address, "$", "") & " non empty and wrapped and merged"
RowTop = RowCrnt
ColLeft = ColCrnt
Call AddressMergedCell(Nothing, Wsht, RowTop, ColLeft, RowBot, ColRight)
Debug.Print "Cell " & Replace(Wsht.Cells(RowTop, ColLeft).Address, "$", "") & ":" & _
Replace(Wsht.Cells(RowBot, ColRight).Address, "$", "") & " merged"
If RowTop <> RowBot Then
' Rows with multi-row merged cells are ignored
Debug.Print "Multirow cell"
MultiRowCellWithinRow = True
OpenMultirowCells.Add RowBot ' Record open multi-row cell
ColCrnt = ColRight
Else
' Note: RowCrnt = RowTop=RowBot ColCrnt <> ColLeft
CellHeights(ColCrnt) = CellHeightMerged(Wsht, RowTop, ColLeft, _
RowBot, ColRight, RowLast + 2, _
ColLastWsht + 2)
' Advance ColCrnt to end of merged cell.
ColCrnt = ColRight
End If
Else
Debug.Print "Cell " & Replace(.Address, "$", "") & _
" non empty, wrapped and not merged"
CellHeights(ColCrnt) = CellHeightUnmerged(Wsht, RowCrnt, _
ColCrnt, RowLast + 2, ColLastWsht + 2)
End If
Else
'Debug.Assert False
Debug.Print "Cell " & Replace(.Address, "$", "") & _
" empty or non wrapped"
End If
End With
' For merged cells, ColCrnt has already been stepped
' for the extra columns within the cell
ColCrnt = ColCrnt + 1
Loop ' While ColCrnt <= ColLastRowCrnt
Debug.Print "Cell heights:";
For ColCrnt = 1 To ColLastRowCrnt
Debug.Print " (" & ColCode(ColCrnt) & ")=" & CellHeights(ColCrnt);
Next
Debug.Print
If MultiRowCellWithinRow Then
Debug.Print "Row cannot be processed because it contains a multi-row cell"
Else
' CellHeight contains the height of every cell within the row that contains
' a value and WrapText=True. Some or all of those CellHeights can be more
' than the maximum height of a row.
Call CalcRowHeights(CellHeights, RowHeights)
Debug.Print "Row height(s):";
For InxR = 1 To UBound(RowHeights)
Debug.Print " " & RowHeights(InxR);
Next
Debug.Print
' RowHeights identifies how many rows are required to properly
' display the current row and the height of those rows
If UBound(RowHeights) = 1 Then
' Only one row required
.Rows(RowCrnt).RowHeight = RowHeights(1)
Else
' Two or more rows required
' Insert extra rows below current row
For InxR = 2 To UBound(RowHeights)
.Rows(RowCrnt + 1).Insert
Next
' Set row heights
RowTemp = RowCrnt
For InxR = 1 To UBound(RowHeights)
.Rows(RowTemp).RowHeight = RowHeights(InxR)
RowTemp = RowTemp + 1
Next
' CellHeights identifies the height of each cell of row with a value
For ColCrnt = 1 To UBound(CellHeights)
If CellHeights(ColCrnt) <> 0 Then
' This cell has a value. Calculate number of rows necessary
' to for the entire value to be visible
CellHeightCrnt = 0#
For InxR = 1 To UBound(RowHeights)
CellHeightCrnt = CellHeightCrnt + RowHeights(InxR)
If CellHeightCrnt >= CellHeights(ColCrnt) Then
' Will need to merge InxR rows to reach required height for cell
Exit For
End If
Next
If InxR > 1 Then
' It is necessary to merge InxR rows for the cell's content
' to be fully visible
' Check for cell being multi-column
RowTop = RowCrnt
ColLeft = ColCrnt
Call AddressMergedCell(Nothing, Wsht, RowTop, ColLeft, RowBot, ColRight)
.Range(.Cells(RowCrnt, ColLeft), _
.Cells(RowCrnt + InxR - 1, ColRight)).Merge
End If
End If
Next
' Allow for inserted rows
RowCrnt = RowCrnt + UBound(RowHeights) - 1
RowLast = RowLast + UBound(RowHeights) - 1
End If
End If
Else
' This row is empty
Debug.Print "Row " & RowCrnt & " empty"
End If
Else
Debug.Print "Row " & RowCrnt & " hidden"
End If
' Clear any open multi-row cells that finished on this row
For InxM = OpenMultirowCells.Count To 1 Step -1
If OpenMultirowCells(InxM) = RowCrnt Then
' RowBot for this multi-row cell = RowCrnt so delete entry
OpenMultirowCells.Remove InxM
End If
Next
RowCrnt = RowCrnt + 1
Loop
' Delete column that includes test cells
.Columns(ColLastWsht + 2).Delete
End With
End Sub