【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