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

流程图

核心算法说明

1. 距离计算公式

距离计算采用欧几里得距离公式：

Distance = √[(x₂-x₁)² + (y₂-y₁)²] * 1000

2. 主要步骤

1. 数据预处理：

   • 获取数据范围
   • 将F列数据读入数组
   • 横向复制到第3行

2. 公式生成：

   • 分批处理以优化性能
   • 使用VLOOKUP查找坐标
   • 应用距离公式计算

3. 性能优化：

   • 批量处理数据
   • 定期清理内存
   • 使用数组减少单元格访问

代码结构

Sub CopyRowToColumn()
    '初始化设置
    '数据处理
    '公式填充
    '清理工作
End Sub

注意事项

1. 内存管理：

   • 分批处理数据
   • 定期清理剪贴板
   • 使用数组代替直接单元格操作

2. 错误处理：

   • 完整的错误处理机制
   • Excel设置的正确还原
   • 用户友好的错误提示

3. 性能考虑：

   • 禁用屏幕更新
   • 禁用自动计算
   • 批量处理数据

V20250109

update note

• 在设置值之前，先将整个区域设置为文本格式 (.NumberFormat = “@”)
• 在设置每个单元格的值时，使用单引号强制文本格式 (“'” & CStr(dataArr(i, 1)))
• 使用CStr函数确保数值转换为文本

Sub PointDistanceUpdate()
    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")
    
    lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
    
    With ws
        colCount = lastRow - 3
        lastCol = 6 + colCount
        
        '先将目标区域设置为文本格式
        .Range(.Cells(3, 7), .Cells(3, lastCol)).NumberFormat = "@"
        
        dataArr = .Range(.Cells(4, 6), .Cells(lastRow, 6)).Value
        
        '设置第3行的值，使用CStr确保是文本格式
        For i = 1 To colCount
            .Cells(3, i + 6).NumberFormat = "@"  '确保单元格是文本格式
            .Cells(3, i + 6).Value = "'" & CStr(dataArr(i, 1))  '添加单引号强制文本
        Next i
        
        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
                
                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 "Point Distance Updated!", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "error: " & Err.Description, vbCritical
    Resume CleanExit
End Sub