VBA实现列值复制为合并单元格新行及动态行高高效设置技术问询

Hey there! Let's tackle your two VBA challenges one by one with clean, efficient solutions.

Your existing code successfully inserts blank rows below each target row, but we need to add logic to copy the column value and merge the cells. I'll assume you want to target column A (you can adjust this easily), and merge the original row and the new blank row for that column.

Here's the revised, complete code:

Sub Macro1()
    Dim LastRow, RowNumber As Long
    Dim ws As Worksheet
    Const TargetCol As String = "A" ' 指定要操作的列，可按需修改
    
    Set ws = ThisWorkbook.Worksheets("Asset")
    With ws
        LastRow = .Cells(.Rows.Count, TargetCol).End(xlUp).Row ' 用指定列获取最后一行，更准确
        
        ' 从下往上循环，避免插入行影响后续循环
        For RowNumber = LastRow To 11 Step -1
            ' 在当前行下方插入空行
            .Rows(RowNumber + 1).Insert
            
            ' 复制当前行指定列的值到新增的空行
            .Range(TargetCol & RowNumber + 1).Value = .Range(TargetCol & RowNumber).Value
            
            ' 合并当前行和新增行的指定列单元格
            .Range(TargetCol & RowNumber & ":" & TargetCol & RowNumber + 1).Merge
            ' 可选：设置合并后单元格的对齐方式，比如居中
            .Range(TargetCol & RowNumber).HorizontalAlignment = xlCenter
            .Range(TargetCol & RowNumber).VerticalAlignment = xlCenter
        Next RowNumber
    End With
End Sub

Key adjustments made: #

• Added a Const TargetCol to easily change the column you want to operate on (no need to hunt through code)
• Fixed the LastRow calculation to use the target column instead of hardcoding column A (more robust)
• Adjusted the insert logic to target RowNumber + 1 (since we're looping from bottom to top, this ensures we insert below the current row correctly)
• Added value copy and cell merging for the target column
• Included optional alignment settings for merged cells (you can remove these if not needed)

Your current approach uses a ton of individual variables and repetitive ElseIf checks, which is hard to maintain. Let's replace that with an array to store threshold-value pairs, then loop through the array to find the correct row height. This makes your code shorter, easier to update, and more efficient.

Here's the optimized code snippet:

Sub AdjustRowHeights()
    Dim wsAsset As Worksheet, wsVar As Worksheet
    Dim thresholdArr As Variant
    Dim i As Long, rowNum As Long
    Dim cellLen As Integer
    
    Set wsAsset = ThisWorkbook.Worksheets("Asset")
    Set wsVar = ThisWorkbook.Worksheets("VariablSheet")
    
    ' 从VariablSheet读取阈值和对应行高，按从大到小排序（对应原来的判断顺序）
    ' 数组格式：{阈值, 行高}，顺序从最高阈值到最低
    thresholdArr = Array( _
        Array(wsVar.Range("F9").Value, 75), _
        Array(wsVar.Range("F8").Value, 65), _
        Array(wsVar.Range("F7").Value, 52), _
        Array(wsVar.Range("F6").Value, 39), _
        Array(wsVar.Range("F5").Value, 26), _
        Array(wsVar.Range("F4").Value, 15) _
    )
    
    With wsAsset
        ' 假设你要处理的行范围是从11开始（和第一个宏对应），可按需调整
        For rowNum = 11 To .Cells(.Rows.Count, "A").End(xlUp).Row Step 2 ' 因为每个原行下面有新增行
            cellLen = Len(.Range("A" & rowNum + 1).Value)
            
            ' 循环数组找匹配的阈值
            For i = LBound(thresholdArr) To UBound(thresholdArr)
                If cellLen > thresholdArr(i)(0) Then
                    .Rows(rowNum + 1).RowHeight = thresholdArr(i)(1)
                    Exit For ' 找到匹配后退出循环，避免多余判断
                End If
            Next i
            
            ' 如果所有阈值都不满足，设置默认行高（可选）
            If .Rows(rowNum + 1).RowHeight = 0 Then
                .Rows(rowNum + 1).RowHeight = 15 ' 默认单行高度
            End If
        Next rowNum
    End With
End Sub

Key improvements: #

• Replaced 25+ individual variables with a single 2D array that stores threshold-row height pairs
• The array follows your original "largest threshold first" logic, so we exit the loop as soon as we find a match (faster execution)
• Easier to update: if you need to add/remove thresholds, just modify the array instead of adding new variables and ElseIf blocks
• Added a default row height fallback in case none of the thresholds are met
• Used descriptive variable names to make the code more readable

Bonus tip: #

If the thresholds in VariablSheet are in a continuous range (like F4:F9), you can even load the array dynamically instead of hardcoding each cell reference:

' 动态加载阈值和行高（假设阈值在F4:F9，对应行高在旁边的列，比如G4:G9）
thresholdArr = wsVar.Range("F4:G9").Value
' 注意：动态加载的数组是1-based，所以循环时要调整：
For i = 1 To UBound(thresholdArr)
    If cellLen > thresholdArr(i, 1) Then
        .Rows(rowNum + 1).RowHeight = thresholdArr(i, 2)
        Exit For
    End If
Next i

This way, you can update the thresholds directly in the worksheet without touching the code at all!

内容的提问来源于stack exchange，提问作者T San