如何在VBA中设置日期格式及带货币符号与千分位的数字格式

原函数仅将提取的固定宽度文本直接赋值给单元格，未处理数据类型转换和格式设置，因此无法自动识别日期、带千分位的货币等格式。我们可以通过扩展字段规则参数并修改函数逻辑来解决这个问题：

1. 修改字段规则（FieldSpecs）格式 #

原规则是起始位置,长度，现在扩展为起始位置,长度,格式代码，不同字段用|分隔：

• 日期格式示例：1,10,mm/dd/yyyy（提取第1-10位，设为月/日/年格式）
• 货币格式示例：11,15,$#,##0.00（提取第11-25位，设为带千分位和两位小数的美元货币格式）
• 无格式需求的字段仍可保留原格式：26,8

2. 修改后的完整函数代码 #

Function ImportFixedWidth(FileName As String, _
     StartCell As Range, _
     IgnoreBlankLines As Boolean, _
     SkipLinesBeginningWith As String, _
     ByVal FieldSpecs As String) As Long

  Dim FINdx As Long
  Dim C As Long
  Dim R As Range
  Dim FNum As Integer
  Dim S As String
  Dim RecCount As Long
  Dim FieldInfos() As String
  Dim FInfo() As String
  Dim N As Long
  Dim T As String
  Dim B As Boolean
  Dim FieldValue As Variant

    Application.EnableCancelKey = xlInterrupt
    On Error GoTo EndOfFunction:

    If Dir(FileName, vbNormal) = vbNullString Then
        ' 文件未找到
        ImportFixedWidth = -1
        Exit Function
    End If

    If Len(FieldSpecs) < 3 Then
        ' 无效的字段规则
        ImportFixedWidth = -1
        Exit Function
    End If

    If StartCell Is Nothing Then
        ImportFixedWidth = -1
        Exit Function
    End If

    Set R = StartCell(1, 1)
    C = R.Column
    FNum = FreeFile

    Open FileName For Input Access Read As #FNum
    ' 移除空格
    FieldSpecs = Replace(FieldSpecs, Space(1), vbNullString)
    ' 移除重复的||
    N = InStr(1, FieldSpecs, "||", vbBinaryCompare)
    Do Until N = 0
        FieldSpecs = Replace(FieldSpecs, "||", "|")
        N = InStr(1, FieldSpecs, "||", vbBinaryCompare)
    Loop
    ' 移除重复的,,
    N = InStr(1, FieldSpecs, ",,", vbBinaryCompare)
    Do Until N = 0
        FieldSpecs = Replace(FieldSpecs, ",,", ",")
        N = InStr(1, FieldSpecs, ",,", vbBinaryCompare)
    Loop

    ' 移除首尾的|字符
    If StrComp(Left(FieldSpecs, 1), "|", vbBinaryCompare) = 0 Then
        FieldSpecs = Mid(FieldSpecs, 2)
    End If
    If StrComp(Right(FieldSpecs, 1), "|", vbBinaryCompare) = 0 Then
        FieldSpecs = Left(FieldSpecs, Len(FieldSpecs) - 1)
    End If

    Do
        ' 读取文件行
        Line Input #FNum, S
        If SkipLinesBeginningWith <> vbNullString And _
                StrComp(Left(Trim(S), Len(SkipLinesBeginningWith)), _
                SkipLinesBeginningWith, vbTextCompare) Then
            If Len(S) = 0 Then
                If IgnoreBlankLines = False Then
                    Set R = R(2, 1)
                End If
            Else
                If FieldSpecs <> vbNullString Then
                    If ImportThisLine(S) = True Then
                        FieldInfos = Split(FieldSpecs, "|")
                        C = R.Column
                       For FINdx = LBound(FieldInfos) To UBound(FieldInfos)
                           FInfo = Split(FieldInfos(FINdx), ",")
                           ' 提取字段文本
                           T = Trim(Mid(S, CLng(FInfo(0)), CLng(FInfo(1))))
                           
                           ' 根据格式代码处理数据类型和格式
                           If UBound(FInfo) >= 2 Then
                               Select Case True
                                   ' 处理日期格式
                                   Case InStr(FInfo(2), "mm") > 0 Or InStr(FInfo(2), "dd") > 0 Or InStr(FInfo(2), "yyyy") > 0
                                       If IsDate(T) Then
                                           FieldValue = CDate(T)
                                           R.EntireRow.Cells(1, C).NumberFormat = FInfo(2)
                                       Else
                                           FieldValue = T
                                       End If
                                   ' 处理数值/货币格式
                                   Case InStr(FInfo(2), "$") > 0 Or InStr(FInfo(2), "#") > 0 Or InStr(FInfo(2), "0") > 0
                                       If IsNumeric(T) Then
                                           FieldValue = CDbl(T)
                                           R.EntireRow.Cells(1, C).NumberFormat = FInfo(2)
                                       Else
                                           FieldValue = T
                                       End If
                                   ' 其他格式直接应用
                                   Case Else
                                       FieldValue = T
                                       R.EntireRow.Cells(1, C).NumberFormat = FInfo(2)
                               End Select
                           Else
                               ' 无格式代码，直接赋值
                               FieldValue = T
                           End If
                           
                           ' 赋值给单元格
                           R.EntireRow.Cells(1, C).Value = FieldValue
                           C = C + 1
                        Next FINdx
                        RecCount = RecCount + 1
                    End If
                    Set R = R(2, 1)
                End If
            End If
        End If

    Loop Until EOF(FNum)

EndOfFunction:
    Close #FNum ' 确保文件关闭
    ImportFixedWidth = RecCount
End Function

' 保留原函数依赖的ImportThisLine函数（如果您的代码中已有可忽略）
Function ImportThisLine(S As String) As Boolean
    ' 这里可以添加自定义的行过滤逻辑，默认返回True
    ImportThisLine = True
End Function

3. 关键改动说明 #

• 新增数据类型转换：将符合条件的文本转为日期/数值类型，确保格式设置生效
• 扩展FieldSpecs参数，支持传入格式代码
• 添加格式判断逻辑，自动识别日期、货币/数值格式并处理
• 新增文件关闭语句，避免资源泄漏

4. 使用示例 #

假设您要导入的固定宽度数据中：

• 第1-10位是日期（格式yyyy-mm-dd）
• 第11-20位是货币（格式¥#,##0.00）
• 第21-30位是普通文本

调用函数的代码如下：

Sub TestImport()
    Dim FilePath As String
    FilePath = "C:\YourDataFile.txt" ' 替换为你的文件路径
    ImportFixedWidth FileName:=FilePath, _
                     StartCell:=Range("A1"), _
                     IgnoreBlankLines:=True, _
                     SkipLinesBeginningWith:=vbNullString, _
                     FieldSpecs:="1,10,yyyy-mm-dd|11,10,¥#,##0.00|21,10"
End Sub

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