【VBA研究】数据格式转换

作者：iamlaosong

将一个系统的数据导出再导入到另一个系统，虽然都是Excel文件，但格式略有不同，所以需要进行转换。功能不复杂，直接引用都可以，但是还是比较麻烦，不如写个工具，进行转换。这样导入文件干干净净，比较好。

唯一要注意的是信息中有身份证号码，在赋值到单元格中时，变成了科学格式或者后面几位都变成0，所以赋值前需要将单元格格式设成文本型（直接将导入模板文件中身份证列设成文本也可以），即：

        Cells(row1, 2).NumberFormat = "@"   '号码单元格设成文本格式

或者将当前行都设置成文本格式：

        Range("A" & row1 & ":G" & row1).NumberFormat = "@"   '号码单元格设成文本格式

VBA代码可以通过 NumberFormat或NumberFormatLocal 属性来设置单元格格式。NumberFormat，单元格格式，这个应该是通用的。NumberFormatLocal，单元格格式，这个是本地的，什么叫本地的，就是与控制面版里面的设置相关的，控制面版可以控制日期格式，货币符号等。两种属性差不多，起码文本属性没看出什么区别。只是觉得这个格式属性名称前面加了个Number比较搞笑，有点多余，还不如不加。

以下是常用的格式代码：

    Selection.NumberFormatLocal = "G/通用格式"  '常规

    Selection.NumberFormatLocal = "0.00_ "  '数值

    Selection.NumberFormatLocal = "￥#,##0.00;￥-#,##0.00" '货币

    Selection.NumberFormatLocal = "_ ￥* #,##0.00_ ;_ ￥* -#,##0.00_ ;_ ￥* " & """" & "-" & """" & "??_ ;_ @_ " '会计专用

    Selection.NumberFormatLocal = "yyyy/m/d;@" '日期

    Selection.NumberFormatLocal = "[$-409]h:mm:ss AM/PM;@" '时间

    Selection.NumberFormatLocal = "0.00%" '百分比

    Selection.NumberFormatLocal = "# ?/?" '分数

    Selection.NumberFormatLocal = "0.00E+00" '科学记数

    Selection.NumberFormatLocal = "@" '文本

    Selection.NumberFormatLocal = "000000" '特殊

    Selection.NumberFormatLocal = "[DBNum2][$-804]G/通用格式" '中文大写 '特殊

    Selection.NumberFormatLocal = "[DBNum2][$RMB]G/通用格式;[红色][DBNum2][$RMB]G/通用格式" '特殊人民币大写"

    Selection.NumberFormatLocal = "yyyy/mm/dd" '日期 '自定义

工具界面：

下面是完整的转换程序

Sub get_data()
    
    Dim arrID()
    
    On Error GoTo Err
    'If MsgBox("开始生成清分数据......", vbOKCancel, "iamlaosong") = vbCancel Then Exit Sub
    
    thisfile = ThisWorkbook.name   '本文件的名字，这样赋值就可以随便改名了
    Worksheets("系统参数").Select
    If Cells(3, 2) = "Y" Or Cells(5, 2) = "y" Then                              '导出出库文件
        Application.ScreenUpdating = True
    Else
        Application.ScreenUpdating = False
    End If
    curdate = Cells(2, 2)
    revfile = Cells(5, 2)                              '文件
    datfile = Cells(6, 2)                              '文件名称
    
    RevFullName = ThisWorkbook.Path & "\" & revfile
    If Dir(RevFullName, vbNormal) <> vbNullString Then
        Workbooks.Open Filename:=RevFullName         '打开文件
        maxrow = [A65536].End(xlUp).Row
    Else
        MsgBox "原始文件不存在！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If
    
    arrID = Range("A4:K" & maxrow)
    Windows(revfile).Close
    maxrow = maxrow - 3
    
    datFullName = ThisWorkbook.Path & "\" & datfile
    If Dir(datFullName, vbNormal) <> vbNullString Then
        Workbooks.Open Filename:=datFullName        '打开文件
        'lineno = [A65536].End(xlUp).Row
        'Range("A2:G" & lineno).ClearContents
    Else
        MsgBox "目标文件不存在！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If
    
    '第一行是标题
    For row1 = 2 To maxrow                  '注意列对应关系
        Cells(row1, 1) = arrID(row1, 2)
        Cells(row1, 2).NumberFormat = "@"   '号码单元格设成文本格式
        Cells(row1, 2) = arrID(row1, 3)
        Cells(row1, 3) = arrID(row1, 5)
        Cells(row1, 4) = arrID(row1, 6)
        Cells(row1, 5) = arrID(row1, 10)
        Cells(row1, 6).NumberFormat = "@"   '号码单元格设成文本格式
        Cells(row1, 6) = arrID(row1, 4)
        Cells(row1, 7) = arrID(row1, 11)
    Next row1
    
    expfile = ThisWorkbook.Path & "\" & curdate & datfile
    ActiveWorkbook.SaveAs Filename:=expfile
    ActiveWorkbook.Close

    'Worksheets("系统参数").Select
    Cells(5, 3) = "成功"
    Cells(6, 3) = "成功"
    
    MsgBox "转换完毕，共" & maxrow - 1 & "条！", vbOKOnly, "iamlaosong"
    Exit Sub
Err:
    MsgBox "错误#" & Str(Err.Number) & Err.Description & "-位置： " & row1, vbOKOnly + vbExclamation, "iamlaosong"
End Sub