【EXCEL】【VBA】根据行数据向右逐列填充求不均匀沉降

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

程序流程图