【VBA】【EXCEL】整理指定sheet里单元格大于1/500的行列编号到新的sheet中

V20250109

Sub FindExceedingValues()
    Dim wsMax As Worksheet, wsMin As Worksheet, wsResult As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim i As Long, j As Long, resultRow As Long
    Dim point1 As String, point2 As String
    Dim startRow As Long
    
    'Set up worksheets
    Set wsMax = ThisWorkbook.Worksheets("03.diff. sett.(Max)")
    Set wsMin = ThisWorkbook.Worksheets("03.diff. sett.(Min)")
    
    'Create or clear result worksheet
    On Error Resume Next
    Set wsResult = ThisWorkbook.Worksheets("04.Over Points List")
    If wsResult Is Nothing Then
        Set wsResult = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsResult.Name = "04.Over Points List"
    End If
    On Error GoTo 0
    
    wsResult.Cells.Clear
    
    'Add headers
    wsResult.Range("A1") = "Sheet Name"
    wsResult.Range("B1") = "Point 1"
    wsResult.Range("C1") = "Point 2"
    wsResult.Range("D1") = "Value"
    
    resultRow = 2
    
    'Process Max sheet
    With wsMax
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
        
        startRow = resultRow
        
        For i = 4 To lastRow
            For j = 13 To lastCol 'Starting from column M (13)
                If IsNumeric(.Cells(i, j).Value) Then
                    If .Cells(i, j).Value > 0.002 Then
                        point1 = "'" & .Cells(3, j).Text  'Use .Text to keep original format
                        point2 = "'" & .Cells(i, "C").Text
                        
                        wsResult.Cells(resultRow, "A").Value = "Max"
                        wsResult.Cells(resultRow, "B").Value = point1
                        wsResult.Cells(resultRow, "C").Value = point2
                        wsResult.Cells(resultRow, "D").Value = .Cells(i, j).Value
                        
                        resultRow = resultRow + 1
                    End If
                End If
            Next j
        Next i
        
        'Merge Max sheet cells if there are results
        If resultRow > startRow Then
            wsResult.Range("A" & startRow & ":A" & resultRow - 1).Merge
        End If
    End With
    
    'Process Min sheet
    With wsMin
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
        lastCol = .Cells(4, .Columns.Count).End(xlToLeft).Column
        
        startRow = resultRow
        
        For i = 4 To lastRow
            For j = 13 To lastCol 'Starting from column M (13)
                If IsNumeric(.Cells(i, j).Value) Then
                    If .Cells(i, j).Value > 0.002 Then
                        point1 = "'" & .Cells(3, j).Text  'Use .Text to keep original format
                        point2 = "'" & .Cells(i, "C").Text
                        
                        wsResult.Cells(resultRow, "A").Value = "Min"
                        wsResult.Cells(resultRow, "B").Value = point1
                        wsResult.Cells(resultRow, "C").Value = point2
                        wsResult.Cells(resultRow, "D").Value = .Cells(i, j).Value
                        
                        resultRow = resultRow