我找到了一个自动适合合并单元格的宏。我将它与另一个宏结合起来循环遍历电子表格并在单元格下方添加一行超过单元格高度408的行。宏在每列中找到单元格，如果单元格超过408，则会添加一行。问题是，宏仅合并一列中的单元格。
我的问题是。如何让宏合并多个列中的单元格，以便单元格AB16与新行17中的下一个单元格合并，G11将单元格与新行12合并。
这是代码。
#include <stdio.h>
#include "mpi.h"
#include <omp.h>
int main(int argc, char *argv[]) {
int numprocs, rank, namelen;
char processor_name[MPI_MAX_PROCESSOR_NAME];
int iam = 0, np = 1;
MPI_Init(&argc, &argv);
MPI_Comm_size(MPI_COMM_WORLD, &numprocs);
MPI_Comm_rank(MPI_COMM_WORLD, &rank);
MPI_Get_processor_name(processor_name, &namelen);
#pragma omp parallel default(shared) private(iam, np)
{
np = omp_get_num_threads();
iam = omp_get_thread_num();
printf("Hello from thread %d out of %d from process %d out of %d on %s\n",
iam, np, rank, numprocs, processor_name);
}
MPI_Finalize();
}
答案 0 :(得分：0)
<强>简介
这个答案比我预期的要长得多。部分是因为我不能因为其他承诺而投入必要的时间，但主要是因为我遇到了我没想到的困难。
一般建议
避免使用活动工作表。如果宏的一个关键特性是用户可以在启动宏之前通过选择它来选择要处理的工作表，那么处理活动工作表可能是合适的。但是，通常宏会处理特定的工作表。在宏中指定该工作表;不要依赖于用户选择了正确的工作表。
避免使用Select。这个建议的正常原因是在工作表中移动选择单元格可能很慢。这是事实，但我的理由是它使代码难以理解。当原始程序员选择一个单元格然后选择偏移然后选择另一个偏移时，您会看到代码。维护程序员应该如何破译正在发生的事情？很少有宏被写入然后被丢弃。六个月或一年后，他们需要更新。可能已经让原始程序员保存几秒钟的技术，或者更糟糕的是，显示出多么聪明的技术可以让维护程序员花费数小时来理解。请记住，您可能是维护程序员。
With rng ... If Not .Parent.Rows(.Cells(j, 1).Row).Hidden我可以想象创建一个范围然后在该范围内操作会有所帮助的情况。但是，如果有时您在该范围内操作，有时您在工作表中操作，则只会使您的代码混乱。
Application.WorksheetFunction.CountA(.Rows(j))使用旧版本的Excel，我发现两个工作表函数在使用Application.WorksheetFunction调用时非常慢。我一直承诺自己会正确调查这个问题。也许这是旧版Excel中的错误。也许Application.WorksheetFunction会产生巨大的开销。我不知道但是如果有一个简单的VBA替代方案，我可以使用它来运行工作表函数。
If Len(.Cells(j, n).Value) Then理解这个语句依赖于读者知道零可以用作布尔值True和非零可以用作布尔值False。我不喜欢依赖这些知识，因为如果读者缺乏这些知识，他们如何理解这种说法呢？你有什么谷歌关于该声明，以发现它的工作原理和原因？
请不要使用j，n或i等变量。它们只会使您的代码难以阅读。
您的日常问题
使用以下方法计算合并单元格的宽度：
For i = 1 To .Cells.Count
MW = MW + .Columns(i).ColumnWidth
Next
您无法以这种方式添加列宽并获得可靠的答案。如果使用Excel查看默认列的宽度，您将看到：“宽度8.43（64像素）”。 8.43是以点为单位的宽度，它是VBA给出和期望的宽度单位。要获得组合宽度，您需要对像素宽度求和，并为每个内部边框添加1。我提供了将点转换为像素的例程，反之亦然。
我的方法
我保留了你的名字MergeandSplit作为主宏，虽然这个名字对我来说没有意义。但是，我已完全记录了您的例程，并且还有许多子例程和函数。
许多年前，我做了类似的事情，但我不知道合并多行以使单元格的整个内容可见。一旦我看到你如何实现这种效果，我就可以轻松找到展示这一技巧的网页。我需要的时候没有找到这些网页，所以我的例行程序涉及拆分细胞。
当单元格超过行限制409.5点时，使用两个409点行。如果单元格仅比行限制略大，则会产生大量空白，如果单元格需要超过818个点，则不起作用。我将一个大的细胞分成几部分并计算组合高度。我根据这个组合高度插入了行数和这些行的高度。虽然我的方法并不完美，但我相信结果比你的方法更令人满意。如果拆分单元格，则会丢失其所有单元格格式。在单元格中，我的意思是单元格的部分是粗体或斜体而部分不是。可以确定原始单元格的单元格格式并将这些格式应用于零件，但这个过程非常慢。我已经破译了过去的格式，并对结果感到满意。也许我只在小型电池上使用它，因为我没有意识到这个过程有多慢。我有一个更快的技术但不能快速提供。我在确定单元格高度时丢弃了格式，但应用了乘法因子。这个乘数适用于我的测试数据，但您可能需要调整它。请参阅我的代码中的第222行。
我包含了很多Debug.Print语句来帮助我开发和测试宏。我已将它们全部留在下面的代码中，以帮助您理解代码。
我尝试使用易于查找的简单语句，尽管我的简单概念可能与您的不一致。尝试自己理解我的代码，因为这将有助于您的开发。回来问题是必要的。
警告：宏在目标工作表上工作，我将其命名为“数据”。用你的名字替换我的名字。在测试宏之前，请确保已保存目标工作表的副本。
答案 1 :(得分：0)
有关此代码的说明，请参阅答案的第一部分：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
答案 2 :(得分：0)
有关此代码的说明，请参阅答案的第一部分：https://stackoverflow.com/a/41036413/973283
包含全局例程的模块。也就是说，我在许多宏中使用的例程
Option Explicit
Dim PixelsForPointsUpTo1() As Double
Dim PixelsForPoints1Up() As Double
Public Sub AddressMergedCell(ByVal Wbk As Workbook, ByVal Wsht As Worksheet, _
ByRef RowTop As Long, ByRef ColLeft As Long, _
ByRef RowBot As Long, ByRef ColRight As Long)
' * If Not Wbk Is Nothing, it identifies the workbook containing the cell to be
' analysed. Otherwise, the active workbook contains the cell to be analysed.
' * If Not WSht Is Nothing, it identifies the sheet containing the cell to be
' analysed. Otherwise, the active sheet contains the cell to be analysed.
' * On entry RowTop and ColLeft identifies a cell. If this cell is not part of
' a merged area then, on exit, RowBot will have been set to RowTop and ColRight
' will have been set to ColLeft. If this cell is part of a merged area then, on
' exit, RowTop, RowBottom, ColLeft and ColRight will identify the boundaries of
' the merged area.
' 21Apr06 Coded. I wrote a similar routine some years ago but I cannot find it.
' 24Apr06 Changed RowTop and RowBottom to Long.
' 11Jun16 Changed ColLeft and ColBottom to Long.
' Tidied up old fashioned names.
' 2Dec16 Replace workbook and worksheet names with workbook and worksheet references
Dim Address As String
Dim AddressParts() As String
Select Case True
Case Wbk Is Nothing And Wsht Is Nothing
'The cell is within the active sheet
Address = ActiveSheet.Cells(RowTop, ColLeft).MergeArea.Address
Case Wbk Is Nothing And Not Wsht Is Nothing
' The cell is within referenced worksheet of the active workbook
Address = Wsht.Cells(RowTop, ColLeft).MergeArea.Address
Case Not Wbk Is Nothing And Not Wsht Is Nothing
' The cell is within the referenced worksheet of the referenced workbook
' A worksheet reference defines it parent. Check Wbk and Wsht match
Debug.Assert Wsht.Parent.Name = Wbk.Name
Address = Wsht.Cells(RowTop, ColLeft).MergeArea.Address
Case Not Wbk Is Nothing And Wsht Is Nothing
' The cell is within the active sheet of a named workbook
Address = Wbk.ActiveSheet.Cells(RowTop, ColLeft).MergeArea.Address
End Select
' Address will be "$" ColumnId "$" RowNum [ ":$" ColumnId "$" RowNum ]
If InStr(1, Address, ":") = 0 Then
' The cell is not part of an merged area
RowBot = RowTop
ColRight = ColLeft
Exit Sub
End If
AddressParts = Split(Address, ":")
RowTop = Range(AddressParts(0)).Row
ColLeft = Range(AddressParts(0)).Column
RowBot = Range(AddressParts(1)).Row
ColRight = Range(AddressParts(1)).Column
End Sub
Function ColCode(ByVal ColNum As Long) As String
Dim PartNum As Long
' 3Feb12 Adapted to handle three character codes.
' 28Oct16 Renamed ColCode to match ColNum.
If ColNum = 0 Then
Debug.Assert False
ColCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
End Function
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
Optional ByVal PadChr As String = " ") As String
' Pad Str with leading PadChr to give a total length of PadLen
' If the length of Str exceeds PadLen, Str will not be truncated
' Sep15 Coded
' 20Dec15 Added code so overlength strings are not truncated
' 10Jun16 Added PadChr so could pad with characters other than space
If Len(Str) >= PadLen Then
' Do not truncate over length strings
PadL = Str
Else
PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
End If
End Function
Function WidthPixelsFromPoints(ByVal Points As Double) As Long
' Convert a column width in points to pixels
' See WidthPrepPixelsPoints for more information
' This routine will return an appropriate value for Pixels even if the
' Points value does not exactly match one of Excel's value.
' For example, Excel has 12 Pixels = 1.00 Points and 13 Pixels = 1.14 Points.
' This routine will round Points 1.01 to 1.13 to Pixels 12 or 13
' 4Dec16 Recoded. Earlier version lost.
Dim Pixels As Long
If Points >= 1# Then
' Handle Points values over 1.00
Pixels = UBound(PixelsForPointsUpTo1)
Points = Points - 1#
Pixels = Pixels + CLng(Points * CDbl(UBound(PixelsForPoints1Up)))
Else
' Handle Points values up to 1.00
Pixels = CLng(Points * CDbl(UBound(PixelsForPointsUpTo1)))
End If
WidthPixelsFromPoints = Pixels
End Function
Function WidthPointsFromPixels(ByVal Pixels As Long) As Double
' Convert a column width in pixels to points
' See WidthPrepPixelsPoints for more information
' 4Dec16 Recoded. Earlier version lost.
Dim Points As Double
If Pixels > UBound(PixelsForPointsUpTo1) Then
' Calculate Pixels for Points above 1.00:
' 1.00 Point = 12 Pixels
' Above 1.00 Points, 1.00 Points = 7 Pixels
Points = 1#
Pixels = Pixels - UBound(PixelsForPointsUpTo1)
' Calculate whole points.
Points = Points + CDbl(Pixels \ UBound(PixelsForPoints1Up))
' Calculate fractional points if any
Points = Points + PixelsForPoints1Up(Pixels Mod UBound(PixelsForPoints1Up))
Else
' Calxulate Pixels for Points below 1.00
Points = PixelsForPointsUpTo1(Pixels)
End If
WidthPointsFromPixels = Points
End Function
Sub WidthPrepPixelsPoints()
' This routine must be run once before either WidthPixelsFromPoints
' or WidthPointsFromPixels are run.
' Excel accepts and returns widths of columns in Points. However,
' sometimes Pixels are required for calculations.
' One Point contains 12 Pixels. Two Points contains 19 Pixels, three Points
' contain 26 Pixels and so on with each additional Point containing an extra
' 7 pixels.
' Note: this information only applies to column widths. For rows:
' Pixels = Points * .75.
' 4Dec16 Recoded. Earlier version lost.
Dim Temp() As Variant
Dim InxT As Long
' Accessing a Double array is faster than accessing a Variant array.
' I have seen it recommended but have not conducted my own time tests to
' determine if Double arrays are sufficiently faster to justify this
' two-step load
Temp = VBA.Array(0#, 0.08, 0.17, 0.25, 0.33, 0.42, 0.5, _
0.58, 0.67, 0.75, 0.83, 0.92, 1#)
ReDim PixelsForPointsUpTo1(0 To UBound(Temp))
For InxT = 0 To UBound(Temp)
PixelsForPointsUpTo1(InxT) = Temp(InxT)
Next
Temp = VBA.Array(0#, 0.14, 0.29, 0.43, 0.57, 0.71, 0.86, 1#)
ReDim PixelsForPoints1Up(0 To UBound(Temp))
For InxT = 0 To UBound(Temp)
PixelsForPoints1Up(InxT) = Temp(InxT)
Next
End Sub