修改VBA代码：在ActiveSheet查找指定表头并复制数据至Sheet2

核心问题分析 #

原代码直接复制A2:AC列的可见单元格，未实现定位"Order No"表头并仅复制该列数据的需求，需重点调整表头定位与数据复制逻辑。

具体修改步骤 #

1. 添加表头定位逻辑
   • 使用Find方法精准定位"Order No"表头单元格，同时处理表头不存在的异常情况
2. 提取目标列数据
   • 从表头下一行开始，获取该列所有有效数据
3. 复制到Sheet2指定区域
   • 将数据复制到Sheet2!A2:A400，超出400行的部分自动截断

调整后的完整代码 #

Private Sub CommandButton8_Click()

Core.TurnOffSettings

Dim NewWB As Workbook
Dim Path As String
Dim orderNoHeader As Range
Dim sourceLastRow As Long
Dim targetMaxRows As Long

' 选择文件并打开工作簿
Path = UserSelectFile("Only Select a RAW copy of the WO report from Apriso" & vbCr & "If you change any lines this process will not work", "Report Select:", 0)
Set NewWB = TransferData2NewBook(Path)

' 定位"Order No"表头
Set orderNoHeader = NewWB.ActiveSheet.Cells.Find( _
    What:="Order No", _
    LookIn:=xlValues, _
    LookAt:=xlWhole, _
    MatchCase:=False) ' 根据需求设置是否区分大小写

' 处理表头未找到的情况
If orderNoHeader Is Nothing Then
    MsgBox "未找到表头'Order No'，终止操作"
    NewWB.Close False
    Core.ResetSettings
    Exit Sub
End If

' 清空Sheet2目标区域
Sheet2.Range("A2:A400").ClearContents

' 获取源数据最后一行
sourceLastRow = FindLastRowSht(NewWB.ActiveSheet)
' 目标区域最大行数（A2到A400共399行）
targetMaxRows = 399

' 复制目标列数据到Sheet2
If sourceLastRow > orderNoHeader.Row Then
    ' 计算实际要复制的行数（取源数据行数和目标最大行数的较小值）
    Dim copyRows As Long
    copyRows = Application.Min(sourceLastRow - orderNoHeader.Row, targetMaxRows)
    
    ' 复制数据（直接赋值比Copy/Paste更高效）
    Sheet2.Range("A2").Resize(copyRows).Value = _
        NewWB.ActiveSheet.Range(orderNoHeader.Offset(1), orderNoHeader.Offset(copyRows)).Value
End If

NewWB.Close False
Core.ResetSettings

' 格式化目标列（保持原有的数字格式处理）
With Sheet2.Range("A2:A400")
 .NumberFormat = "0"
 .Value = .Value
End With

Sheet3.Range("W6").Value = Now
Sheets("Dashboard").Select

End Sub

关键修改点说明 #

• 表头定位：用Find方法精准匹配表头，添加异常判断避免程序崩溃
• 数据范围控制：限制复制行数不超过A2:A400的容量，防止超出目标区域
• 高效赋值：直接用Value属性传递数据，比Copy/Paste更快且避免格式问题
• 明确工作表对象：将ActiveSheet替换为NewWB.ActiveSheet，避免因激活状态变化导致错误

内容的提问来源于stack exchange，提问作者Andrew