Excel VBA提取数据时Workbook自动转为科学计数法问题求助

编写VBA代码提取路径不固定的.csv和.xls文件数据，但使用Workbooks.Open打开文件时，部分长数字类数据自动转为科学计数法，引发提取逻辑错误和数据解读偏差。手动通过Excel「文件>打开」选择无分隔符打开，数据仍保持科学计数法格式。

原VBA代码 #

Sub ExtractData()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim SourceFile As Variant
Dim SourceWB As Workbook
Dim wsRs As Worksheet
Dim PTDate As Date, SODate As Date
Dim ProcSteps As Range
Set wsRs = ThisWorkbook.Sheets("References")

wsRs.Activate
Set ProcSteps = wsRs.Range(Cells(2, 1), Cells(2, 1).End(xlDown))
Range("M:M, P:P,AA:AA").ColumnWidth = 25
'--------------get prod trackout data--------------
SourceFile = Application.GetOpenFilename(Title:="Please select Production TrackOut File ('FwWeb0101')", Filefilter:="Text Files(*.csv),csv*") 'get filepath
If SourceFile <> False Then
Set SourceWB = Application.Workbooks.Open(SourceFile)
Range("A:J").ColumnWidth = 25
Range("A:B,D:D,F:H,K:M,O:R").Delete Shift:=xlToLeft
Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).AutoFilter Field:=1, Criteria1:=Split(Join(Application.Transpose(ProcSteps), ","), ","), Operator:=xlFilterValues
Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).Copy Destination:=wsRs.Cells(1, 10)
SourceWB.Close
'--------------get step output report data--------------
SourceFile = Application.GetOpenFilename(Title:="Please select B800 Step Output Report File ('basenameFwCal0025')", Filefilter:="Excel Files(.xls),*xls*") 'get filepath
If SourceFile <> False Then
Set SourceWB = Application.Workbooks.Open(SourceFile)
Range("B:B,D:D,K:N,P:R").Delete Shift:=xlToLeft
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add2 Key:=Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add2 Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Columns("A:J")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'-------------------------copy all lots-----------------
Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).AutoFilter Field:=2, Criteria1:=Split(Join(Application.Transpose(ProcSteps), ","), ","), Operator:=xlFilterValues
Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).Copy Destination:=wsRs.Cells(1, 16)
SourceWB.Close
'------------------------check workweek----------------
Else:   MsgBox "No B800 Step Output Report file was selected.", vbCritical ' no file selected
With wsRs.Columns("J:N")
.Clear
.ColumnWidth = 8.11
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Exit Sub
End If
Else:   MsgBox "No Production TrackOut file was selected.", vbCritical ' no file selected
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.DisplayStatusBar = True
Exit Sub
End If
ThisWorkbook.Save
End Sub

解决方案 #

1. 处理CSV文件：用OpenText强制指定列格式为文本 #

CSV文件的自动格式转换是Excel默认行为，改用OpenText打开并指定需要保留原样的列为文本格式，彻底避免科学计数法转换。

替换原代码中打开CSV的Set SourceWB = Application.Workbooks.Open(SourceFile)部分：

' 用OpenText打开CSV，指定列格式（示例：第1、3列设为文本，其余通用格式，按需调整）
Workbooks.OpenText Filename:=SourceFile, _
    Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, Comma:=True, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Space:=False, Other:=False, _
    FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlGeneralFormat), Array(3, xlTextFormat))
Set SourceWB = ActiveWorkbook

• FieldInfo参数：每个子数组对应一列，第一个值是列序号，第二个值是格式（xlTextFormat为文本，xlGeneralFormat为默认通用格式），根据实际需要调整列的序号和格式。

2. 处理XLS文件：打开后强制设置文本格式 #

XLS文件如果已存在自动转换的问题，打开后将目标列设置为文本格式并重新赋值，恢复原始数据：

替换原代码中打开XLS的Set SourceWB = Application.Workbooks.Open(SourceFile)部分：

Set SourceWB = Application.Workbooks.Open(SourceFile)
' 将需要保留原样的列（比如A、C列）设置为文本格式
SourceWB.ActiveSheet.Columns("A,C").NumberFormat = "@" ' 按需调整列
' 重新赋值，修正已转换为科学计数法的数据
SourceWB.ActiveSheet.Columns("A,C").Value = SourceWB.ActiveSheet.Columns("A,C").Value

3. 复制数据时保留格式 #

复制粘贴时使用PasteSpecial确保值和格式一起复制，避免粘贴时再次触发格式转换：
替换原代码中的复制粘贴语句，比如：

Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).Copy
wsRs.Cells(1, 10).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False

4. 手动打开CSV的正确方式 #

手动打开时，在文本分列向导中：

• 选择分隔符（CSV一般是逗号）
• 选中需要保留原样的列，设置「列数据格式」为「文本」，再完成导入

修改后的完整VBA代码 #

Sub ExtractData()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim SourceFile As Variant
Dim SourceWB As Workbook
Dim wsRs As Worksheet
Dim PTDate As Date, SODate As Date
Dim ProcSteps As Range
Set wsRs = ThisWorkbook.Sheets("References")

wsRs.Activate
Set ProcSteps = wsRs.Range(Cells(2, 1), Cells(2, 1).End(xlDown))
Range("M:M, P:P,AA:AA").ColumnWidth = 25
'--------------get prod trackout data--------------
SourceFile = Application.GetOpenFilename(Title:="Please select Production TrackOut File ('FwWeb0101')", Filefilter:="Text Files(*.csv),csv*") 'get filepath
If SourceFile <> False Then
    ' 替换Open为OpenText，强制列格式
    Workbooks.OpenText Filename:=SourceFile, _
        Origin:=xlWindows, StartRow:=1, DataType:=xlDelimited, Comma:=True, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Space:=False, Other:=False, _
        FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlGeneralFormat), Array(3, xlTextFormat)) ' 按需调整列格式
    Set SourceWB = ActiveWorkbook
    
    Range("A:J").ColumnWidth = 25
    Range("A:B,D:D,F:H,K:M,O:R").Delete Shift:=xlToLeft
    Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).AutoFilter Field:=1, Criteria1:=Split(Join(Application.Transpose(ProcSteps), ","), ","), Operator:=xlFilterValues
    ' 复制粘贴保留格式
    Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).Copy
    wsRs.Cells(1, 10).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False
    
    SourceWB.Close
    '--------------get step output report data--------------
    SourceFile = Application.GetOpenFilename(Title:="Please select B800 Step Output Report File ('basenameFwCal0025')", Filefilter:="Excel Files(.xls),*xls*") 'get filepath
    If SourceFile <> False Then
        Set SourceWB = Application.Workbooks.Open(SourceFile)
        ' 设置目标列为文本格式并修正数据
        SourceWB.ActiveSheet.Columns("A,C").NumberFormat = "@" ' 按需调整列
        SourceWB.ActiveSheet.Columns("A,C").Value = SourceWB.ActiveSheet.Columns("A,C").Value
        
        Range("B:B,D:D,K:N,P:R").Delete Shift:=xlToLeft
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Columns("B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SortFields.Add2 Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange Columns("A:J")
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        '-------------------------copy all lots-----------------
        Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).AutoFilter Field:=2, Criteria1:=Split(Join(Application.Transpose(ProcSteps), ","), ","), Operator:=xlFilterValues
        ' 复制粘贴保留格式
        Range(Cells(1, 1), Cells(1, 1).End(xlToRight).End(xlDown)).Copy
        wsRs.Cells(1, 16).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
        
        SourceWB.Close
        '------------------------check workweek----------------
    Else:   MsgBox "No B800 Step Output Report file was selected.", vbCritical ' no file selected
        With wsRs.Columns("J:N")
            .Clear
            .ColumnWidth = 8.11
        End With
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.DisplayStatusBar = True
        Exit Sub
    End If
Else:   MsgBox "No Production TrackOut file was selected.", vbCritical ' no file selected
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.DisplayStatusBar = True
    Exit Sub
End If
ThisWorkbook.Save
End Sub

内容的提问来源于stack exchange，提问作者Princess Danica Serot