Sub CopyRowToColumn()On Error GoTo ErrorHandler '添加错误处理Application.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = False '禁用事件处理Dim lastCol As LongDim lastRow As LongDim i As Long, colCount As LongDim ws As WorksheetDim formulaStr As StringDim dataArr() As Variant '使用数组来处理数据Set ws = ThisWorkbook.Worksheets("03.Obj Geom - Point Coordinates")'获取F列的最后一行lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).RowWith ws'计算需要生成的列数colCount = lastRow - 3lastCol = 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 LongDim currentCol As LongbatchSize = 50For currentCol = 7 To lastCol Step batchSizeDim endCol As LongendCol = Application.Min(currentCol + batchSize - 1, lastCol)'为这一批列设置公式For i = currentCol To endColDim colAddr As StringcolAddr = .Cells(3, i).ValueformulaStr = "=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:=xlFillDefaultEnd If'每10列清理一次剪贴板和内存If i Mod 10 = 0 ThenApplication.CutCopyMode = FalseDoEventsEnd IfNext iNext currentColEnd WithCleanExit:Application.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueApplication.EnableEvents = TrueApplication.CutCopyMode = FalseMsgBox "操作完成!", vbInformationExit SubErrorHandler:MsgBox "发生错误: " & Err.Description, vbCriticalResume CleanExit
End Sub
流程图
核心算法说明
1. 距离计算公式
距离计算采用欧几里得距离公式：
Distance = √[(x₂-x₁)² + (y₂-y₁)²] * 1000
2. 主要步骤
-
数据预处理：
- 获取数据范围
- 将F列数据读入数组
- 横向复制到第3行
-
公式生成：
- 分批处理以优化性能
- 使用VLOOKUP查找坐标
- 应用距离公式计算
-
性能优化：
- 批量处理数据
- 定期清理内存
- 使用数组减少单元格访问
代码结构
Sub CopyRowToColumn()'初始化设置'数据处理'公式填充'清理工作
End Sub
注意事项
-
内存管理：
- 分批处理数据
- 定期清理剪贴板
- 使用数组代替直接单元格操作
-
错误处理：
- 完整的错误处理机制
- Excel设置的正确还原
- 用户友好的错误提示
-
性能考虑：
- 禁用屏幕更新
- 禁用自动计算
- 批量处理数据
V20250109
update note
- 在设置值之前，先将整个区域设置为文本格式 (.NumberFormat = “@”)
- 在设置每个单元格的值时，使用单引号强制文本格式 (“'” & CStr(dataArr(i, 1)))
- 使用CStr函数确保数值转换为文本
Sub PointDistanceUpdate()On Error GoTo ErrorHandlerApplication.ScreenUpdating = FalseApplication.Calculation = xlCalculationManualApplication.EnableEvents = FalseDim lastCol As LongDim lastRow As LongDim i As Long, colCount As LongDim ws As WorksheetDim formulaStr As StringDim dataArr() As VariantSet ws = ThisWorkbook.Worksheets("03.Obj Geom - Point Coordinates")lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).RowWith wscolCount = lastRow - 3lastCol = 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 iDim batchSize As LongDim currentCol As LongbatchSize = 50For currentCol = 7 To lastCol Step batchSizeDim endCol As LongendCol = Application.Min(currentCol + batchSize - 1, lastCol)For i = currentCol To endColDim colAddr As StringcolAddr = .Cells(3, i).ValueformulaStr = "=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:=xlFillDefaultEnd IfIf i Mod 10 = 0 ThenApplication.CutCopyMode = FalseDoEventsEnd IfNext iNext currentColEnd WithCleanExit:Application.Calculation = xlCalculationAutomaticApplication.ScreenUpdating = TrueApplication.EnableEvents = TrueApplication.CutCopyMode = FalseMsgBox "Point Distance Updated!", vbInformationExit SubErrorHandler:MsgBox "error: " & Err.Description, vbCriticalResume CleanExit
End Sub
