Sub CopyMaxAndMinRowsAndTranspose()
Dim wsSource As Worksheet
Dim wsTargetMax As Worksheet
Dim wsTargetMin As Worksheet
Dim lastRow As Long
Dim i As Long, targetRowMax As Long, targetRowMin As Long
Dim sourceData As Variant
Dim maxRows() As Long, minRows() As Long
Dim maxCount As Long, minCount As Long
Dim startTime As Double
startTime = Timer
'Optimize Performance
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'Set source worksheet
Set wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")
'Check and create Max worksheet if it doesn't exist
On Error Resume Next
Set wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
If wsTargetMax Is Nothing Then
Set 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 exist
Set wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
If wsTargetMin Is Nothing Then
Set wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTargetMin.Name = "03.diff. sett.(Min)"
End If
On Error GoTo 0
'Clear target worksheets content
wsTargetMax.Cells.Clear
wsTargetMin.Cells.Clear
'Get last row and load data into array
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
sourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
'Initialize arrays
ReDim maxRows(1 To lastRow)
ReDim minRows(1 To lastRow)
maxCount = 0
minCount = 0
'Find all MAX and MIN rows
For i = 4 To UBound(sourceData, 1)
If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" Then
maxCount = maxCount + 1
maxRows(maxCount) = i
ElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" Then
minCount = minCount + 1
minRows(minCount) = i
End If
Next i
'Resize arrays to actual size
ReDim 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 operation
If maxCount > 0 Then
Dim maxRange As Range
Set maxRange = wsSource.Rows(maxRows(1))
For i = 2 To maxCount
Set maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))
Next i
maxRange.Copy wsTargetMax.Rows(4)
End If
'Copy MIN rows in one operation
If minCount > 0 Then
Dim minRange As Range
Set minRange = wsSource.Rows(minRows(1))
For i = 2 To minCount
Set minRange = Union(minRange, wsSource.Rows(minRows(i)))
Next i
minRange.Copy wsTargetMin.Rows(4)
End If
'处理Max sheet的转置
If maxCount > 0 Then
Dim maxDataArr As Variant
maxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value
'Transfer max data to horizontal array
Dim maxTargetArr() As Variant
ReDim 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 horizontally
wsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArr
'添加公式并向下填充
With wsTargetMax
Dim lastRowMax As Long
lastRowMax = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(maxDataArr, 1)
'获取列字母
Dim colLetter As String
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(lastRowMax, i + 12)).FillDown
Next i
End With
End If
'处理Min sheet的转置
If minCount > 0 Then
Dim minDataArr As Variant
minDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value
'Transfer min data to horizontal array
Dim minTargetArr() As Variant
ReDim 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 horizontally
wsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArr
'添加公式并向下填充
With wsTargetMin
Dim lastRowMin As Long
lastRowMin = .Cells(.Rows.Count, "C").End(xlUp).Row
For 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)).FillDown
Next i
End With
End If
'Format the worksheets
wsTargetMax.Columns.AutoFit
wsTargetMin.Columns.AutoFit
'Restore settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Debug.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 Worksheet
Dim wsTargetMax As Worksheet
Dim wsTargetMin As Worksheet
Dim lastRow As Long
Dim i As Long, targetRowMax As Long, targetRowMin As Long
Dim sourceData As Variant
Dim maxRows() As Long, minRows() As Long
Dim maxCount As Long, minCount As Long
Dim startTime As Double
startTime = Timer
'Optimize Performance
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
'Set source worksheet
Set wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")
'Check and create Max worksheet if it doesn't exist
Set wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
If wsTargetMax Is Nothing Then
Set 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 exist
Set wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
If wsTargetMin Is Nothing Then
Set wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTargetMin.Name = "03.diff. sett.(Min)"
End If
On Error GoTo 0
'Clear target worksheets content
wsTargetMax.Cells.Clear
wsTargetMin.Cells.Clear
'Get last row and load data into array
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
sourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
'Initialize arrays
ReDim maxRows(1 To lastRow)
ReDim minRows(1 To lastRow)
maxCount = 0
minCount = 0
'Find all MAX and MIN rows
For i = 4 To UBound(sourceData, 1)
If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" Then
maxCount = maxCount + 1
maxRows(maxCount) = i
ElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" Then
minCount = minCount + 1
minRows(minCount) = i
End If
Next i
'Resize arrays to actual size
ReDim 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 operation
If maxCount > 0 Then
Dim maxRange As Range
Set maxRange = wsSource.Rows(maxRows(1))
For i = 2 To maxCount
Set maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))
Next i
maxRange.Copy wsTargetMax.Rows(4)
End If
'Copy MIN rows in one operation
If minCount > 0 Then
Dim minRange As Range
Set minRange = wsSource.Rows(minRows(1))
For i = 2 To minCount
Set minRange = Union(minRange, wsSource.Rows(minRows(i)))
Next i
minRange.Copy wsTargetMin.Rows(4)
End If
'处理Max sheet的转置
If maxCount > 0 Then
Dim maxDataArr As Variant
maxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value
'Transfer max data to horizontal array
Dim maxTargetArr() As Variant
ReDim 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 horizontally
wsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArr
With wsTargetMax
Dim lastRowMax As Long
lastRowMax = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(maxDataArr, 1)
Dim colLetter As String
colLetter = Split(wsTargetMax.Cells(1, i + 12).Address, "$")(1)
'Modified formula generation
For j = 4 To lastRowMax
Dim refColumn As String
refColumn = 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 j
Next i
'Add conditional formatting for max values
Dim maxDataRange As Range
Set maxDataRange = .Range(.Cells(4, 13), .Cells(lastRowMax, 12 + UBound(maxDataArr, 1)))
maxDataRange.FormatConditions.Delete
With 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 With
End If
'处理Min sheet的转置
If minCount > 0 Then
Dim minDataArr As Variant
minDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value
'Transfer min data to horizontal array
Dim minTargetArr() As Variant
ReDim 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 horizontally
wsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArr
With wsTargetMin
Dim lastRowMin As Long
lastRowMin = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(minDataArr, 1)
colLetter = Split(wsTargetMin.Cells(1, i + 12).Address, "$")(1)
'Modified formula generation
For j = 4 To lastRowMin
refColumn = 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 j
Next i
'Add conditional formatting for min values
Dim minDataRange As Range
Set minDataRange = .Range(.Cells(4, 13), .Cells(lastRowMin, 12 + UBound(minDataArr, 1)))
minDataRange.FormatConditions.Delete
With 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 With
End If
'Format the worksheets
wsTargetMax.Columns.AutoFit
wsTargetMin.Columns.AutoFit
'Restore settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Debug.Print "执行时间: " & Format(Timer - startTime, "0.00") & " 秒"
MsgBox "数据处理完成！" & vbNewLine & _
"Max行数: " & maxCount & vbNewLine & _
"Min行数: " & minCount & vbNewLine & _
"执行时间: " & Format(Timer - startTime, "0.00") & " 秒", vbInformation
End Sub
V20250106 English reminder
Sub CopyMaxAndMinRowsAndTranspose()
Dim wsSource As Worksheet
Dim wsTargetMax As Worksheet
Dim wsTargetMin As Worksheet
Dim lastRow As Long
Dim i As Long, targetRowMax As Long, targetRowMin As Long
Dim sourceData As Variant
Dim maxRows() As Long, minRows() As Long
Dim maxCount As Long, minCount As Long
Dim startTime As Double
startTime = Timer
'Optimize Performance
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
'Set source worksheet
Set wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")
'Check and create Max worksheet if it doesn't exist
Set wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
If wsTargetMax Is Nothing Then
Set 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 exist
Set wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
If wsTargetMin Is Nothing Then
Set wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTargetMin.Name = "03.diff. sett.(Min)"
End If
On Error GoTo 0
'Clear target worksheets content
wsTargetMax.Cells.Clear
wsTargetMin.Cells.Clear
'Get last row and load data into array
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
sourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
'Initialize arrays
ReDim maxRows(1 To lastRow)
ReDim minRows(1 To lastRow)
maxCount = 0
minCount = 0
'Find all MAX and MIN rows
For i = 4 To UBound(sourceData, 1)
If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" Then
maxCount = maxCount + 1
maxRows(maxCount) = i
ElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" Then
minCount = minCount + 1
minRows(minCount) = i
End If
Next i
'Resize arrays to actual size
ReDim 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 operation
If maxCount > 0 Then
Dim maxRange As Range
Set maxRange = wsSource.Rows(maxRows(1))
For i = 2 To maxCount
Set maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))
Next i
maxRange.Copy wsTargetMax.Rows(4)
End If
'Copy MIN rows in one operation
If minCount > 0 Then
Dim minRange As Range
Set minRange = wsSource.Rows(minRows(1))
For i = 2 To minCount
Set minRange = Union(minRange, wsSource.Rows(minRows(i)))
Next i
minRange.Copy wsTargetMin.Rows(4)
End If
'处理Max sheet的转置
If maxCount > 0 Then
Dim maxDataArr As Variant
maxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value
'Transfer max data to horizontal array
Dim maxTargetArr() As Variant
ReDim 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 horizontally
wsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArr
With wsTargetMax
Dim lastRowMax As Long
lastRowMax = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(maxDataArr, 1)
Dim colLetter As String
colLetter = Split(wsTargetMax.Cells(1, i + 12).Address, "$")(1)
For j = 4 To lastRowMax
Dim refColumn As String
refColumn = 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 j
Next i
'Add conditional formatting for max values
Dim maxDataRange As Range
Set maxDataRange = .Range(.Cells(4, 13), .Cells(lastRowMax, 12 + UBound(maxDataArr, 1)))
maxDataRange.FormatConditions.Delete
With 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 With
End If
'处理Min sheet的转置
If minCount > 0 Then
Dim minDataArr As Variant
minDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value
'Transfer min data to horizontal array
Dim minTargetArr() As Variant
ReDim 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 horizontally
wsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArr
With wsTargetMin
Dim lastRowMin As Long
lastRowMin = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(minDataArr, 1)
colLetter = Split(wsTargetMin.Cells(1, i + 12).Address, "$")(1)
For j = 4 To lastRowMin
refColumn = 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 j
Next i
'Add conditional formatting for min values
Dim minDataRange As Range
Set minDataRange = .Range(.Cells(4, 13), .Cells(lastRowMin, 12 + UBound(minDataArr, 1)))
minDataRange.FormatConditions.Delete
With 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 With
End If
'Format the worksheets
wsTargetMax.Columns.AutoFit
wsTargetMin.Columns.AutoFit
'Restore settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Debug.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
V20250109 verify text formation
update note
- 在设置值之前，先将整个区域设置为文本格式 (.NumberFormat = “@”)
- 在设置每个单元格的值时，使用单引号强制文本格式 (“'” & CStr(dataArr(i, 1)))
- 使用CStr函数确保数值转换为文本
Sub DifferentialSettlementUpdate()
Dim wsSource As Worksheet
Dim wsTargetMax As Worksheet
Dim wsTargetMin As Worksheet
Dim lastRow As Long
Dim i As Long, targetRowMax As Long, targetRowMin As Long
Dim sourceData As Variant
Dim maxRows() As Long, minRows() As Long
Dim maxCount As Long, minCount As Long
Dim startTime As Double
startTime = Timer
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
Set wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")
Set wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
If wsTargetMax Is Nothing Then
Set wsTargetMax = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTargetMax.Name = "03.diff. sett.(Max)"
End If
Set wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
If wsTargetMin Is Nothing Then
Set wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsTargetMin.Name = "03.diff. sett.(Min)"
End If
On Error GoTo 0
wsTargetMax.Cells.Clear
wsTargetMin.Cells.Clear
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
sourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
ReDim maxRows(1 To lastRow)
ReDim minRows(1 To lastRow)
maxCount = 0
minCount = 0
For i = 4 To UBound(sourceData, 1)
If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" Then
maxCount = maxCount + 1
maxRows(maxCount) = i
ElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" Then
minCount = minCount + 1
minRows(minCount) = i
End If
Next i
ReDim 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 Then
Dim maxRange As Range
Set maxRange = wsSource.Rows(maxRows(1))
For i = 2 To maxCount
Set maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))
Next i
maxRange.Copy wsTargetMax.Rows(4)
End If
If minCount > 0 Then
Dim minRange As Range
Set minRange = wsSource.Rows(minRows(1))
For i = 2 To minCount
Set minRange = Union(minRange, wsSource.Rows(minRows(i)))
Next i
minRange.Copy wsTargetMin.Rows(4)
End If
If maxCount > 0 Then
Dim maxDataArr As Variant
maxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value
Dim maxTargetArr() As Variant
ReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))
For i = 1 To UBound(maxDataArr, 1)
' 添加单引号确保文本格式
maxTargetArr(1, i) = "'" & CStr(maxDataArr(i, 1))
Next i
wsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArr
With wsTargetMax
Dim lastRowMax As Long
lastRowMax = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(maxDataArr, 1)
Dim colLetter As String
colLetter = Split(wsTargetMax.Cells(1, i + 12).Address, "$")(1)
For j = 4 To lastRowMax
Dim refColumn As String
refColumn = 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 j
Next i
Dim maxDataRange As Range
Set maxDataRange = .Range(.Cells(4, 13), .Cells(lastRowMax, 12 + UBound(maxDataArr, 1)))
maxDataRange.FormatConditions.Delete
With 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 With
End If
If minCount > 0 Then
Dim minDataArr As Variant
minDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value
Dim minTargetArr() As Variant
ReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))
For i = 1 To UBound(minDataArr, 1)
' 添加单引号确保文本格式
minTargetArr(1, i) = "'" & CStr(minDataArr(i, 1))
Next i
wsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArr
With wsTargetMin
Dim lastRowMin As Long
lastRowMin = .Cells(.Rows.Count, "C").End(xlUp).Row
For i = 1 To UBound(minDataArr, 1)
colLetter = Split(wsTargetMin.Cells(1, i + 12).Address, "$")(1)
For j = 4 To lastRowMin
refColumn = 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 j
Next i
Dim minDataRange As Range
Set minDataRange = .Range(.Cells(4, 13), .Cells(lastRowMin, 12 + UBound(minDataArr, 1)))
minDataRange.FormatConditions.Delete
With 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 With
End If
wsTargetMax.Columns.AutoFit
wsTargetMin.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Debug.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
V20250109 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 Worksheet
Dim wsTargetMax As Worksheet
Dim wsTargetMin As Worksheet
Dim lastRow As Long
Dim i As Long, targetRowMax As Long, targetRowMin As Long
Dim sourceData As Variant
Dim maxRows() As Long, minRows() As Long
Dim maxCount As Long, minCount As Long
Dim startTime As Double
startTime = Timer
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
Set wsSource = ThisWorkbook.Worksheets("03.Nodal Displacements(pileset)")
Set wsTargetMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
If wsTargetMax Is Nothing Then
Set wsTargetMax = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count))
wsTargetMax.Name = "03.diff. sett.(Max)"
End If
Set wsTargetMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
If wsTargetMin Is Nothing Then
Set wsTargetMin = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count))
wsTargetMin.Name = "03.diff. sett.(Min)"
End If
On Error GoTo 0
wsTargetMax.Cells.Clear
wsTargetMin.Cells.Clear
lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).row
sourceData = wsSource.Range(wsSource.Cells(1, 1), wsSource.Cells(lastRow, wsSource.Cells(1, Columns.Count).End(xlToLeft).Column)).Value
ReDim maxRows(1 To lastRow)
ReDim minRows(1 To lastRow)
maxCount = 0
minCount = 0
For i = 4 To UBound(sourceData, 1)
If UCase(Trim(CStr(sourceData(i, 1)))) = "MAX" Then
maxCount = maxCount + 1
maxRows(maxCount) = i
ElseIf UCase(Trim(CStr(sourceData(i, 1)))) = "MIN" Then
minCount = minCount + 1
minRows(minCount) = i
End If
Next i
ReDim 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 Then
Dim maxRange As Range
Set maxRange = wsSource.Rows(maxRows(1))
For i = 2 To maxCount
Set maxRange = Union(maxRange, wsSource.Rows(maxRows(i)))
Next i
maxRange.Copy wsTargetMax.Rows(4)
End If
If minCount > 0 Then
Dim minRange As Range
Set minRange = wsSource.Rows(minRows(1))
For i = 2 To minCount
Set minRange = Union(minRange, wsSource.Rows(minRows(i)))
Next i
minRange.Copy wsTargetMin.Rows(4)
End If
If maxCount > 0 Then
Dim maxDataArr As Variant
maxDataArr = wsTargetMax.Range("C4:C" & (maxCount + 3)).Value
Dim maxTargetArr() As Variant
ReDim maxTargetArr(1 To 1, 1 To UBound(maxDataArr, 1))
For i = 1 To UBound(maxDataArr, 1)
maxTargetArr(1, i) = "'" & CStr(maxDataArr(i, 1))
Next i
wsTargetMax.Range("M3").Resize(1, UBound(maxDataArr, 1)) = maxTargetArr
With wsTargetMax
Dim lastRowMax As Long
lastRowMax = .Cells(.Rows.Count, "C").End(xlUp).row
For i = 1 To UBound(maxDataArr, 1)
Dim colLetter As String
colLetter = 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 j
Next i
Dim maxDataRange As Range
Set maxDataRange = .Range(.Cells(4, 13), .Cells(lastRowMax, 12 + UBound(maxDataArr, 1)))
maxDataRange.FormatConditions.Delete
With maxDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=0.002)
.Interior.Color = RGB(255, 0, 0)
End With
With 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 With
End If
If minCount > 0 Then
Dim minDataArr As Variant
minDataArr = wsTargetMin.Range("C4:C" & (minCount + 3)).Value
Dim minTargetArr() As Variant
ReDim minTargetArr(1 To 1, 1 To UBound(minDataArr, 1))
For i = 1 To UBound(minDataArr, 1)
minTargetArr(1, i) = "'" & CStr(minDataArr(i, 1))
Next i
wsTargetMin.Range("M3").Resize(1, UBound(minDataArr, 1)) = minTargetArr
With wsTargetMin
Dim lastRowMin As Long
lastRowMin = .Cells(.Rows.Count, "C").End(xlUp).row
For 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 j
Next i
Dim minDataRange As Range
Set minDataRange = .Range(.Cells(4, 13), .Cells(lastRowMin, 12 + UBound(minDataArr, 1)))
minDataRange.FormatConditions.Delete
With minDataRange.FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:=0.002)
.Interior.Color = RGB(255, 0, 0)
End With
With 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 With
End If
wsTargetMax.Columns.AutoFit
wsTargetMin.Columns.AutoFit
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.CutCopyMode = False
End With
Debug.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