【VBA】【EXCEL】将某列内容横向粘贴到指定行

c 复制代码

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

流程图

是否错误开始禁用Excel自动更新获取工作表引用获取F列最后一行计算需要生成的列数读取F列数据到数组横向复制F列数据到第3行分批处理列公式是否还有未处理的列? 设置当前批次的列范围构建距离计算公式填充公式到整列清理内存恢复Excel设置结束错误处理

核心算法说明

1. 距离计算公式

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

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

2. 主要步骤

数据预处理：
- 获取数据范围
- 将F列数据读入数组
- 横向复制到第3行
公式生成：
- 分批处理以优化性能
- 使用VLOOKUP查找坐标
- 应用距离公式计算
性能优化：
- 批量处理数据
- 定期清理内存
- 使用数组减少单元格访问

代码结构

vb 复制代码

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

注意事项

内存管理：
- 分批处理数据
- 定期清理剪贴板
- 使用数组代替直接单元格操作
错误处理：
- 完整的错误处理机制
- Excel设置的正确还原
- 用户友好的错误提示
性能考虑：
- 禁用屏幕更新
- 禁用自动计算
- 批量处理数据