【VBA】【EXCEL】退据坐标数据向右逐列填充求所有点之间的距离

Sub CopyRowToColumn()
    On Error GoTo ErrorHandler  '添加错误处理
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False  '禁用事件处理
    
    Dim lastCol As Long
    Dim lastRow As Long
    Dim i As Long, colCount As Long
    Dim ws As Worksheet
    Dim formulaStr As String
    Dim dataArr() As Variant  '使用数组来处理数据
    
    Set ws = ThisWorkbook.Worksheets("03.Obj Geom - Point Coordinates")
    
    '获取F列的最后一行
    lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
    
    With ws
        '计算需要生成的列数
        colCount = lastRow - 3
        lastCol = 6 + colCount
        
        '将F列数据读入数组
        dataArr = .Range(.Cells(4, 6), .Cells(lastRow, 6)).Value
        
        '设置第3行的值
        For i = 1 To colCount
            .Cells(3, i + 6).Value = dataArr(i, 1)
        Next i
        
        '每次处理50列，分批设置公式
        Dim batchSize As Long
        Dim currentCol As Long
        batchSize = 50
        
        For currentCol = 7 To lastCol Step batchSize
            Dim endCol As Long
            endCol = Application.Min(currentCol + batchSize - 1, lastCol)
            
            '为这一批列设置公式
            For i = currentCol To endCol
                Dim colAddr As String
                colAddr = .Cells(3, i).Value
                
                formulaStr = "=IFERROR(ROUND(SQRT(((VLOOKUP(""" & colAddr & """,$A$1:$D$" & lastRow & ",2,FALSE)-" & _
                            "VLOOKUP($F{row},$A$1:$D$" & lastRow & ",2,FALSE))^2+" & _
                            "(VLOOKUP(""" & colAddr & """,$A$1:$D$" & lastRow & ",3,FALSE)-" & _
                            "VLOOKUP($F{row},$A$1:$D$" & lastRow & ",3,FALSE))^2))*1000,0),"""")"
                
                .Cells(4, i).Formula = Replace(formulaStr, "{row}", "4")
                
                If lastRow > 4 Then
                    .Cells(4, i).AutoFill _
                        Destination:=.Range(.Cells(4, i), .Cells(lastRow, i)), _
                        Type:=xlFillDefault
                End If
                
                '每10列清理一次剪贴板和内存
                If i Mod 10 = 0 Then
                    Application.CutCopyMode = False
                    DoEvents
                End If
            Next i
        Next currentCol
    End With
    
CleanExit:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.CutCopyMode = False
    MsgBox "操作完成!", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "发生错误: " & Err.Description, vbCritical
    Resume CleanExit
End Sub

流程图