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 SubV20250109 verify text formation
update note
- 在设置值之前，先将整个区域设置为文本格式 (.NumberFormat = “@”)
- 在设置每个单元格的值时，使用单引号强制文本格式 (“'” & CStr(dataArr(i, 1)))
- 使用CStr函数确保数值转换为文本
Sub DifferentialSettlementUpdate()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 = TimerWith Application.ScreenUpdating = False.EnableEvents = False.Calculation = xlCalculationManualEnd WithOn Error Resume NextSet wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")Set 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 IfSet 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 0wsTargetMax.Cells.ClearwsTargetMin.Cells.ClearlastRow = 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)).ValueReDim maxRows(1 To lastRow)ReDim minRows(1 To lastRow)maxCount = 0minCount = 0For 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 iReDim Preserve maxRows(1 To maxCount)ReDim Preserve minRows(1 To minCount)wsSource.Rows("1:3").Copy wsTargetMax.Rows("1")wsSource.Rows("1:3").Copy wsTargetMin.Rows("1")' 设置目标工作表的格式为文本wsTargetMax.Range("M3").Resize(1, maxCount).NumberFormat = "@"wsTargetMin.Range("M3").Resize(1, minCount).NumberFormat = "@"If 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 IfIf 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 IfIf maxCount > 0 ThenDim maxDataArr As VariantmaxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).ValueDim maxTargetArr() As VariantReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))For i = 1 To UBound(maxDataArr, 1)' 添加单引号确保文本格式maxTargetArr(1, i) = "'" & CStr(maxDataArr(i, 1))Next iwsTargetMax.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 iDim 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.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 IfIf minCount > 0 ThenDim minDataArr As VariantminDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).ValueDim minTargetArr() As VariantReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))For i = 1 To UBound(minDataArr, 1)' 添加单引号确保文本格式minTargetArr(1, i) = "'" & CStr(minDataArr(i, 1))Next iwsTargetMin.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 iDim 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.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 IfwsTargetMax.Columns.AutoFitwsTargetMin.Columns.AutoFitWith 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 SubV20250109 inner formula directly cite coordination and calculate distance
- sometimes , if distance table and settlement table not absolutely map, may led result wrong, so just use one formula to calculate settlement ,and distance table just for reference.
Sub DifferentialSettlementUpdate()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 = TimerWith Application.ScreenUpdating = False.EnableEvents = False.Calculation = xlCalculationManualEnd WithOn Error Resume NextSet wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")Set 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 IfSet 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 0wsTargetMax.Cells.ClearwsTargetMin.Cells.ClearlastRow = 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)).ValueReDim maxRows(1 To lastRow)ReDim minRows(1 To lastRow)maxCount = 0minCount = 0For 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 iReDim Preserve maxRows(1 To maxCount)ReDim Preserve minRows(1 To minCount)wsSource.Rows("1:3").Copy wsTargetMax.Rows("1")wsSource.Rows("1:3").Copy wsTargetMin.Rows("1")wsTargetMax.Range("M3").Resize(1, maxCount).NumberFormat = "@"wsTargetMin.Range("M3").Resize(1, minCount).NumberFormat = "@"If 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 IfIf 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 IfIf maxCount > 0 ThenDim maxDataArr As VariantmaxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).ValueDim maxTargetArr() As VariantReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))For i = 1 To UBound(maxDataArr, 1)maxTargetArr(1, i) = "'" & CStr(maxDataArr(i, 1))Next iwsTargetMax.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 lastRowMax.Cells(j, i + 12).Formula = "=IFERROR(ROUND(ABS(VLOOKUP(TRIM($C" & j & "),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/(SQRT((VLOOKUP($C" & j & ",'03.Obj Geom - Point Coordinates'!$A:$E,2,FALSE)-VLOOKUP(" & colLetter & "$3,'03.Obj Geom - Point Coordinates'!$A:$E,2,FALSE))^2+(VLOOKUP($C" & j & ",'03.Obj Geom - Point Coordinates'!$A:$E,3,FALSE)-VLOOKUP(" & colLetter & "$3,'03.Obj Geom - Point Coordinates'!$A:$E,3,FALSE))^2))/1000,4),"""")".Cells(j, i + 12).NumberFormat = "0.0000"Next jNext iDim 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 WithWith maxDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="""""").Interior.Color = RGB(192, 192, 192)End With.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 IfIf minCount > 0 ThenDim minDataArr As VariantminDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).ValueDim minTargetArr() As VariantReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))For i = 1 To UBound(minDataArr, 1)minTargetArr(1, i) = "'" & CStr(minDataArr(i, 1))Next iwsTargetMin.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 lastRowMin.Cells(j, i + 12).Formula = "=IFERROR(ROUND(ABS(VLOOKUP(TRIM($C" & j & "),$C:$H,6,FALSE)-VLOOKUP(TRIM(" & colLetter & "$3),$C:$H,6,FALSE))/(SQRT((VLOOKUP($C" & j & ",'03.Obj Geom - Point Coordinates'!$A:$E,2,FALSE)-VLOOKUP(" & colLetter & "$3,'03.Obj Geom - Point Coordinates'!$A:$E,2,FALSE))^2+(VLOOKUP($C" & j & ",'03.Obj Geom - Point Coordinates'!$A:$E,3,FALSE)-VLOOKUP(" & colLetter & "$3,'03.Obj Geom - Point Coordinates'!$A:$E,3,FALSE))^2))/1000,4),"""")".Cells(j, i + 12).NumberFormat = "0.0000"Next jNext iDim 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 WithWith minDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="""""").Interior.Color = RGB(192, 192, 192)End With.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 IfwsTargetMax.Columns.AutoFitwsTargetMin.Columns.AutoFitWith 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
