当前位置：首页 > article >正文

【EXCEL】【VBA】最大值行索引查找与Z字形数据重排

article 2025/2/13 4:43:51

一、公式获取列中最大值及所对应的行号

1. 获取区域最大值

=MAX(IF(ROW(N:N)>3,N:N,""))

原理解析：

ROW(N:N) - 返回行号
IF(ROW(N:N)>3,N:N,"") - 过滤第3行之后的数据
MAX() - 计算最大值

2. 查找最大值位置

=MATCH(MAX(IF(ROW(O:O)>3,O:O,"")),IF(ROW(O:O)>3,O:O,""),0)

函数组合：

内层：找出最大值
外层：MATCH 函数定位最大值位置
最后参数 0 表示精确匹配

3. 引用最大值对应单元格

=INDEX(A:A,MATCH(MAX(IF(ROW(N:N)>3,N:N,"")),IF(ROW(N:N)>3,N:N,""),0))

函数链：

二、VBA 实现 Z 字形数据重排

1. 程序流程图

2. 核心代码解析

2.1 性能优化设置

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

2.2 工作表操作

' 删除已存在的工作表
On Error Resume Next
ThisWorkbook.Worksheets("Z排列结果").Delete
On Error GoTo 0

' 创建新工作表
Set ws2 = ThisWorkbook.Worksheets.Add
ws2.Name = "Z排列结果"

2.3 数据复制循环

For i = 1 To lastCol Step 10
    colsToTransfer = Application.Min(10, lastCol - i + 1)
    
    ' 复制三行数据
    ws1.Range(...).Copy
    ws2.Cells(...).PasteSpecial xlPasteValues
    
    newRow = newRow + 3
Next i

2.4 页面设置

With ws2.PageSetup
    .Orientation = xlPortrait
    .PaperSize = xlPaperA4
    .FitToPagesWide = 1
    .PrintGridlines = True
End With

3. 关键技术要点

错误处理：使用 On Error Resume Next 和 On Error GoTo 0
性能优化：禁用屏幕刷新和自动计算
循环控制：使用 Step 关键字控制步长
页面布局：使用 PageSetup 对象设置打印格式

4. 实用技巧

动态范围：

lastCol = ws1.Cells(3, ws1.Columns.Count).End(xlToLeft).Column

分页处理：

For j = 10 To ws2.UsedRange.Columns.Count Step 10
    ws2.Columns(j).PageBreak = xlPageBreakManual
Next j

自动列宽：

ws2.UsedRange.Columns.AutoFit

v20250210

Sub RearrangeRowsInZPatternWithPageSetup()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastCol As Long
    Dim newRow As Long
    Dim newCol As Long
    Dim i As Long
    
    ' 设置源工作表
    Set ws1 = ThisWorkbook.Worksheets("03.Obj Geom - Point Coordinates")
    
    ' 创建新工作表
    On Error Resume Next
    ThisWorkbook.Worksheets("Z排列结果").Delete
    On Error GoTo 0
    Set ws2 = ThisWorkbook.Worksheets.Add
    ws2.Name = "Z排列结果"
    
    ' 获取最后一列
    lastCol = ws1.Cells(3, ws1.Columns.Count).End(xlToLeft).Column
    
    ' 初始化新位置计数器
    newRow = 1
    newCol = 1
    
    ' 每10列为一组进行复制
    For i = 1 To lastCol Step 10
        ' 确定当前组的列数
        Dim colsToTransfer As Long
        colsToTransfer = Application.Min(10, lastCol - i + 1)
        
        ' 直接复制值
        ws1.Range(ws1.Cells(3, i), ws1.Cells(3, i + colsToTransfer - 1)).Copy
        ws2.Cells(newRow, newCol).PasteSpecial xlPasteValues
        
        ws1.Range(ws1.Cells(4, i), ws1.Cells(4, i + colsToTransfer - 1)).Copy
        ws2.Cells(newRow + 1, newCol).PasteSpecial xlPasteValues
        
        ws1.Range(ws1.Cells(5, i), ws1.Cells(5, i + colsToTransfer - 1)).Copy
        ws2.Cells(newRow + 2, newCol).PasteSpecial xlPasteValues
        
        ' 更新行位置
        newRow = newRow + 3
    Next i
    
    Application.CutCopyMode = False
    
    ' 批量设置列宽
    ws2.UsedRange.Columns.AutoFit
    
    ' 设置页面布局
    With ws2.PageSetup
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4
        .LeftMargin = Application.CentimetersToPoints(2)
        .RightMargin = Application.CentimetersToPoints(2)
        .TopMargin = Application.CentimetersToPoints(2)
        .BottomMargin = Application.CentimetersToPoints(2)
        .FitToPagesTall = False
        .FitToPagesWide = 1
        .PrintGridlines = True
    End With
    

    
    ' 批量添加分页符
    Dim j As Long
    For j = 10 To ws2.UsedRange.Columns.Count Step 10
        ws2.Columns(j).PageBreak = xlPageBreakManual
    Next j
    
    ' 设置视图
    ws2.Parent.Windows(1).View = xlPageBreakPreview
    ws2.Parent.Windows(1).Zoom = 120
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "finished", vbInformation
End Sub