Sub CopyMaxAndMinRowsAndTranspose()Dim wsSource As WorksheetDim wsTargetMax As WorksheetDim wsTargetMin As WorksheetDim lastRow As LongDim i As Long, targetRowMax As Long, targetRowMin As LongDim sourceData As VariantDim maxRows() As Long, minRows() As LongDim maxCount As Long, minCount As LongDim startTime As DoublestartTime = Timer'Optimize PerformanceWith Application.ScreenUpdating = False.EnableEvents = False.Calculation = xlCalculationManualEnd With'Set source worksheetSet wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")'Check and create Max worksheet if it doesn't existOn Error Resume NextSet wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")If wsTargetMax Is Nothing ThenSet wsTargetMax = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsTargetMax.Name = "03.diff. sett.(Max)"End If'Check and create Min worksheet if it doesn't existSet wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")If wsTargetMin Is Nothing ThenSet wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsTargetMin.Name = "03.diff. sett.(Min)"End IfOn Error GoTo 0'Clear target worksheets contentwsTargetMax.Cells.ClearwsTargetMin.Cells.Clear'Get last row and load data into arraylastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).RowsourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value'Initialize arraysReDim maxRows(1 To lastRow)ReDim minRows(1 To lastRow)maxCount = 0minCount = 0'Find all MAX and MIN rowsFor i = 4 To UBound(sourceData, 1)If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" ThenmaxCount = maxCount + 1maxRows(maxCount) = iElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" ThenminCount = minCount + 1minRows(minCount) = iEnd IfNext i'Resize arrays to actual sizeReDim Preserve maxRows(1 To maxCount)ReDim Preserve minRows(1 To minCount)'Copy header rows (1-3)wsSource.Rows("1:3").Copy wsTargetMax.Rows("1")wsSource.Rows("1:3").Copy wsTargetMin.Rows("1")'Copy MAX rows in one operationIf maxCount > 0 ThenDim maxRange As RangeSet maxRange = wsSource.Rows(maxRows(1))For i = 2 To maxCountSet maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))Next imaxRange.Copy wsTargetMax.Rows(4)End If'Copy MIN rows in one operationIf minCount > 0 ThenDim minRange As RangeSet minRange = wsSource.Rows(minRows(1))For i = 2 To minCountSet minRange = Union(minRange, wsSource.Rows(minRows(i)))Next iminRange.Copy wsTargetMin.Rows(4)End If'处理Max sheet的转置If maxCount > 0 ThenDim maxDataArr As VariantmaxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value'Transfer max data to horizontal arrayDim maxTargetArr() As VariantReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))For i = 1 To UBound(maxDataArr, 1)maxTargetArr(1, i) = maxDataArr(i, 1)Next i'Write max array horizontallywsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArr'添加公式并向下填充With wsTargetMaxDim lastRowMax As LonglastRowMax = .Cells(.Rows.Count, "C").End(xlUp).RowFor i = 1 To UBound(maxDataArr, 1)'获取列字母Dim colLetter As StringcolLetter = Split(.Cells(1, i + 12).Address, "$")(1)'先写入第4行的公式.Cells(4, i + 12).Formula = "=ABS(VLOOKUP(TRIM($C4),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!G4"'将公式向下填充到最后一行.Range(.Cells(4, i + 12), .Cells(lastRowMax, i + 12)).FillDownNext iEnd WithEnd If'处理Min sheet的转置If minCount > 0 ThenDim minDataArr As VariantminDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value'Transfer min data to horizontal arrayDim minTargetArr() As VariantReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))For i = 1 To UBound(minDataArr, 1)minTargetArr(1, i) = minDataArr(i, 1)Next i'Write min array horizontallywsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArr'添加公式并向下填充With wsTargetMinDim lastRowMin As LonglastRowMin = .Cells(.Rows.Count, "C").End(xlUp).RowFor i = 1 To UBound(minDataArr, 1)'获取列字母colLetter = Split(.Cells(1, i + 12).Address, "$")(1)'先写入第4行的公式.Cells(4, i + 12).Formula = "=ABS(VLOOKUP(TRIM($C4),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!G4"'将公式向下填充到最后一行.Range(.Cells(4, i + 12), .Cells(lastRowMin, i + 12)).FillDownNext iEnd WithEnd If'Format the worksheetswsTargetMax.Columns.AutoFitwsTargetMin.Columns.AutoFit'Restore settingsWith Application.ScreenUpdating = True.EnableEvents = True.Calculation = xlCalculationAutomatic.CutCopyMode = FalseEnd WithDebug.Print "执行时间: " & Format(Timer - startTime, "0.00") & " 秒"MsgBox "数据处理完成！" & vbNewLine & _"Max行数: " & maxCount & vbNewLine & _"Min行数: " & minCount & vbNewLine & _"执行时间: " & Format(Timer - startTime, "0.00") & " 秒", vbInformation
End Sub
程序流程图
主要功能模块说明
1. 初始化设置
- 关闭屏幕刷新
- 禁用事件
- 设置手动计算模式
2. 工作表处理
- 检查并创建Max和Min工作表
- 清空目标工作表内容
3. 数据提取
- 读取源数据
- 识别MAX和MIN行
- 复制相关数据
4. 数据转置与计算
- 水平转置数据
- 添加计算公式：
=ABS(VLOOKUP(TRIM($C4),$C:$H,6,FALSE)-VLOOKUP(TRIM(列字母$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!G4
5. 格式化和完成
- 自动调整列宽
- 恢复Excel设置
- 显示执行统计信息
性能优化特点
- 使用数组处理数据
- 批量复制而非逐行复制
- 优化Excel设置提高运行速度
- 使用Union方法合并范围操作
执行结果展示
程序完成后会显示：
- Max行数统计
- Min行数统计
- 执行时间（秒）
V20250106
Sub CopyMaxAndMinRowsAndTranspose()Dim wsSource As WorksheetDim wsTargetMax As WorksheetDim wsTargetMin As WorksheetDim lastRow As LongDim i As Long, targetRowMax As Long, targetRowMin As LongDim sourceData As VariantDim maxRows() As Long, minRows() As LongDim maxCount As Long, minCount As LongDim startTime As DoublestartTime = Timer'Optimize PerformanceWith Application.ScreenUpdating = False.EnableEvents = False.Calculation = xlCalculationManualEnd WithOn Error Resume Next'Set source worksheetSet wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")'Check and create Max worksheet if it doesn't existSet wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")If wsTargetMax Is Nothing ThenSet wsTargetMax = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsTargetMax.Name = "03.diff. sett.(Max)"End If'Check and create Min worksheet if it doesn't existSet wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")If wsTargetMin Is Nothing ThenSet wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsTargetMin.Name = "03.diff. sett.(Min)"End IfOn Error GoTo 0'Clear target worksheets contentwsTargetMax.Cells.ClearwsTargetMin.Cells.Clear'Get last row and load data into arraylastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).RowsourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value'Initialize arraysReDim maxRows(1 To lastRow)ReDim minRows(1 To lastRow)maxCount = 0minCount = 0'Find all MAX and MIN rowsFor i = 4 To UBound(sourceData, 1)If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" ThenmaxCount = maxCount + 1maxRows(maxCount) = iElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" ThenminCount = minCount + 1minRows(minCount) = iEnd IfNext i'Resize arrays to actual sizeReDim Preserve maxRows(1 To maxCount)ReDim Preserve minRows(1 To minCount)'Copy header rows (1-3)wsSource.Rows("1:3").Copy wsTargetMax.Rows("1")wsSource.Rows("1:3").Copy wsTargetMin.Rows("1")'Copy MAX rows in one operationIf maxCount > 0 ThenDim maxRange As RangeSet maxRange = wsSource.Rows(maxRows(1))For i = 2 To maxCountSet maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))Next imaxRange.Copy wsTargetMax.Rows(4)End If'Copy MIN rows in one operationIf minCount > 0 ThenDim minRange As RangeSet minRange = wsSource.Rows(minRows(1))For i = 2 To minCountSet minRange = Union(minRange, wsSource.Rows(minRows(i)))Next iminRange.Copy wsTargetMin.Rows(4)End If'处理Max sheet的转置If maxCount > 0 ThenDim maxDataArr As VariantmaxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value'Transfer max data to horizontal arrayDim maxTargetArr() As VariantReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))For i = 1 To UBound(maxDataArr, 1)maxTargetArr(1, i) = maxDataArr(i, 1)Next i'Write max array horizontallywsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArrWith wsTargetMaxDim lastRowMax As LonglastRowMax = .Cells(.Rows.Count, "C").End(xlUp).RowFor i = 1 To UBound(maxDataArr, 1)Dim colLetter As StringcolLetter = Split(wsTargetMax.Cells(1, i + 12).Address, "$")(1)'Modified formula generationFor j = 4 To lastRowMaxDim refColumn As StringrefColumn = Split(Cells(1, i + 6).Address, "$")(1) '从G列(7)开始，随i递增.Cells(j, i + 12).formula = "=IF('03.Obj Geom - Point Coordinates'!" & refColumn & j & "=0,0,ABS(VLOOKUP(TRIM($C" & j & "),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!" & refColumn & j & ")"Next jNext i'Add conditional formatting for max valuesDim maxDataRange As RangeSet maxDataRange = .Range(.Cells(4, 13), .Cells(lastRowMax, 12 + UBound(maxDataArr, 1)))maxDataRange.FormatConditions.DeleteWith maxDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=0.002).Interior.Color = RGB(255, 0, 0)End With'Add check formula in M1.Range("M1").formula = "=IF(MAX(M4:" & Split(.Cells(4, 12 + UBound(maxDataArr, 1)).Address, "$")(1) & lastRowMax & ")>0.002,""存在大于0.002的值"",""全部符合要求"")"End WithEnd If'处理Min sheet的转置If minCount > 0 ThenDim minDataArr As VariantminDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value'Transfer min data to horizontal arrayDim minTargetArr() As VariantReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))For i = 1 To UBound(minDataArr, 1)minTargetArr(1, i) = minDataArr(i, 1)Next i'Write min array horizontallywsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArrWith wsTargetMinDim lastRowMin As LonglastRowMin = .Cells(.Rows.Count, "C").End(xlUp).RowFor i = 1 To UBound(minDataArr, 1)colLetter = Split(wsTargetMin.Cells(1, i + 12).Address, "$")(1)'Modified formula generationFor j = 4 To lastRowMinrefColumn = Split(Cells(1, i + 6).Address, "$")(1) '从G列(7)开始，随i递增.Cells(j, i + 12).formula = "=IF('03.Obj Geom - Point Coordinates'!" & refColumn & j & "=0,0,ABS(VLOOKUP(TRIM($C" & j & "),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!" & refColumn & j & ")"Next jNext i'Add conditional formatting for min valuesDim minDataRange As RangeSet minDataRange = .Range(.Cells(4, 13), .Cells(lastRowMin, 12 + UBound(minDataArr, 1)))minDataRange.FormatConditions.DeleteWith minDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=0.002).Interior.Color = RGB(255, 0, 0)End With'Add check formula in M1.Range("M1").formula = "=IF(MAX(M4:" & Split(.Cells(4, 12 + UBound(minDataArr, 1)).Address, "$")(1) & lastRowMin & ")>0.002,""存在大于0.002的值"",""全部符合要求"")"End WithEnd If'Format the worksheetswsTargetMax.Columns.AutoFitwsTargetMin.Columns.AutoFit'Restore settingsWith Application.ScreenUpdating = True.EnableEvents = True.Calculation = xlCalculationAutomatic.CutCopyMode = FalseEnd WithDebug.Print "执行时间: " & Format(Timer - startTime, "0.00") & " 秒"MsgBox "数据处理完成！" & vbNewLine & _"Max行数: " & maxCount & vbNewLine & _"Min行数: " & minCount & vbNewLine & _"执行时间: " & Format(Timer - startTime, "0.00") & " 秒", vbInformation
End SubV20250106 English reminder
Sub CopyMaxAndMinRowsAndTranspose()Dim wsSource As WorksheetDim wsTargetMax As WorksheetDim wsTargetMin As WorksheetDim lastRow As LongDim i As Long, targetRowMax As Long, targetRowMin As LongDim sourceData As VariantDim maxRows() As Long, minRows() As LongDim maxCount As Long, minCount As LongDim startTime As DoublestartTime = Timer'Optimize PerformanceWith Application.ScreenUpdating = False.EnableEvents = False.Calculation = xlCalculationManualEnd WithOn Error Resume Next'Set source worksheetSet wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")'Check and create Max worksheet if it doesn't existSet wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")If wsTargetMax Is Nothing ThenSet wsTargetMax = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsTargetMax.Name = "03.diff. sett.(Max)"End If'Check and create Min worksheet if it doesn't existSet wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")If wsTargetMin Is Nothing ThenSet wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsTargetMin.Name = "03.diff. sett.(Min)"End IfOn Error GoTo 0'Clear target worksheets contentwsTargetMax.Cells.ClearwsTargetMin.Cells.Clear'Get last row and load data into arraylastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).RowsourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value'Initialize arraysReDim maxRows(1 To lastRow)ReDim minRows(1 To lastRow)maxCount = 0minCount = 0'Find all MAX and MIN rowsFor i = 4 To UBound(sourceData, 1)If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" ThenmaxCount = maxCount + 1maxRows(maxCount) = iElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" ThenminCount = minCount + 1minRows(minCount) = iEnd IfNext i'Resize arrays to actual sizeReDim Preserve maxRows(1 To maxCount)ReDim Preserve minRows(1 To minCount)'Copy header rows (1-3)wsSource.Rows("1:3").Copy wsTargetMax.Rows("1")wsSource.Rows("1:3").Copy wsTargetMin.Rows("1")'Copy MAX rows in one operationIf maxCount > 0 ThenDim maxRange As RangeSet maxRange = wsSource.Rows(maxRows(1))For i = 2 To maxCountSet maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))Next imaxRange.Copy wsTargetMax.Rows(4)End If'Copy MIN rows in one operationIf minCount > 0 ThenDim minRange As RangeSet minRange = wsSource.Rows(minRows(1))For i = 2 To minCountSet minRange = Union(minRange, wsSource.Rows(minRows(i)))Next iminRange.Copy wsTargetMin.Rows(4)End If'处理Max sheet的转置If maxCount > 0 ThenDim maxDataArr As VariantmaxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value'Transfer max data to horizontal arrayDim maxTargetArr() As VariantReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))For i = 1 To UBound(maxDataArr, 1)maxTargetArr(1, i) = maxDataArr(i, 1)Next i'Write max array horizontallywsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArrWith wsTargetMaxDim lastRowMax As LonglastRowMax = .Cells(.Rows.Count, "C").End(xlUp).RowFor i = 1 To UBound(maxDataArr, 1)Dim colLetter As StringcolLetter = Split(wsTargetMax.Cells(1, i + 12).Address, "$")(1)For j = 4 To lastRowMaxDim refColumn As StringrefColumn = Split(Cells(1, i + 6).Address, "$")(1).Cells(j, i + 12).formula = "=ROUND(IF('03.Obj Geom - Point Coordinates'!" & refColumn & j & "=0,0,ABS(VLOOKUP(TRIM($C" & j & "),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!" & refColumn & j & "),4)".Cells(j, i + 12).NumberFormat = "0.0000"Next jNext i'Add conditional formatting for max valuesDim maxDataRange As RangeSet maxDataRange = .Range(.Cells(4, 13), .Cells(lastRowMax, 12 + UBound(maxDataArr, 1)))maxDataRange.FormatConditions.DeleteWith maxDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=0.002).Interior.Color = RGB(255, 0, 0)End With'Add check formula in M1.Range("M1").formula = "=IF(MAX(M4:" & Split(.Cells(4, 12 + UBound(maxDataArr, 1)).Address, "$")(1) & lastRowMax & ")>0.002,""Values > 0.002 exist"",""All values within limits"")"End WithEnd If'处理Min sheet的转置If minCount > 0 ThenDim minDataArr As VariantminDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value'Transfer min data to horizontal arrayDim minTargetArr() As VariantReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))For i = 1 To UBound(minDataArr, 1)minTargetArr(1, i) = minDataArr(i, 1)Next i'Write min array horizontallywsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArrWith wsTargetMinDim lastRowMin As LonglastRowMin = .Cells(.Rows.Count, "C").End(xlUp).RowFor i = 1 To UBound(minDataArr, 1)colLetter = Split(wsTargetMin.Cells(1, i + 12).Address, "$")(1)For j = 4 To lastRowMinrefColumn = Split(Cells(1, i + 6).Address, "$")(1).Cells(j, i + 12).formula = "=ROUND(IF('03.Obj Geom - Point Coordinates'!" & refColumn & j & "=0,0,ABS(VLOOKUP(TRIM($C" & j & "),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/'03.Obj Geom - Point Coordinates'!" & refColumn & j & "),4)".Cells(j, i + 12).NumberFormat = "0.0000"Next jNext i'Add conditional formatting for min valuesDim minDataRange As RangeSet minDataRange = .Range(.Cells(4, 13), .Cells(lastRowMin, 12 + UBound(minDataArr, 1)))minDataRange.FormatConditions.DeleteWith minDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=0.002).Interior.Color = RGB(255, 0, 0)End With'Add check formula in M1.Range("M1").formula = "=IF(MAX(M4:" & Split(.Cells(4, 12 + UBound(minDataArr, 1)).Address, "$")(1) & lastRowMin & ")>0.002,""Values > 0.002 exist"",""All values within limits"")"End WithEnd If'Format the worksheetswsTargetMax.Columns.AutoFitwsTargetMin.Columns.AutoFit'Restore settingsWith Application.ScreenUpdating = True.EnableEvents = True.Calculation = xlCalculationAutomatic.CutCopyMode = FalseEnd WithDebug.Print "Execution time: " & Format(Timer - startTime, "0.00") & " seconds"MsgBox "Data processing completed!" & vbNewLine & _"Max rows: " & maxCount & vbNewLine & _"Min rows: " & minCount & vbNewLine & _"Execution time: " & Format(Timer - startTime, "0.00") & " seconds", vbInformation
End Sub