用宏读取Excel数据生成文本文件

最近有个项目用到宏，差不多都忘光了。记得刚上大学的时候，那个年代是VB流行的季节，因此与Excel结合小用过。
恰巧从Excel中读出数据，形成报盘文件。下面列出基本的编程要点：

Global Const INITIAL_COL = 64
Function getCellValue(sheetName As String, rowNum As Integer, colNo As Integer) As String
  getCellValue = Sheets(sheetName).Range(Chr(colNo + INITIAL_COL) & rowNum).Value

End Function

Function setCellValue(sheetName As String, rowNum As Integer, colNo As Integer, strValue As String)
  Sheets(sheetName).Range(Chr(colNo + INITIAL_COL) & rowNum).Value = strValue
End Function

On Error GoTo Err_Line

Set fso = CreateObject("Scripting.FileSystemObject")

Set objText = fso.CreateTextFile(sFileName)


'**Define Sheet Name
sResourceSheet = "ResourceFile"

'**Initialization
iRecordCount = 0
nTotalPremAmount = 0

'**Write the header into the text file, header row no is 1
iRowNo = 1

' Trans Code, the length is 5
sHeaderTransCode = Left(UCase(getCellValue(sResourceSheet, iRowNo, 1)) & Space(5), 8)


sHeaderDate = getCellValue(sResourceSheet, iRowNo, 3)

sFiller1 = String(9, "0")

'Check and format the header Date
If Len(sHeaderDate) = 6 Then
    sHeaderDate = Right(sHeaderDate, 4)
ElseIf Len(sHeaderDate) <> 4 Then
    'Report Error, Date is not standard
    sErrorMsg = "The Header Date you specified is not correct, please use correct date format YYYYMM or YYMM!"

    GoTo Err_Line
End If

'Combine Header Record
sHeaderRecord = sHeaderTransCode & sFiller1 & sHeaderDate

Call objText.WriteLine(sHeaderRecord)

'**row no, content body get started from row 3
iRowNo = 3

While getCellValue(sResourceSheet, iRowNo, 1) <> "" And UCase(getCellValue(sResourceSheet, iRowNo, 2)) <> "END"

  '**Handling Date,format is "yyyymmdd"
  sDate = getCellValue(sResourceSheet, iRowNo, 1)
  '**Transaction Code, length is 5
  sTransCode = Left(getCellValue(sResourceSheet, iRowNo, 2) & Space(5), 5)
  '**Premium Amount
  If IsNumeric(getCellValue(sResourceSheet, iRowNo, 4)) = True Then
    nPremAmount = Val(getCellValue(sResourceSheet, iRowNo, 4))
  Else
    sErrorMsg = "Line " & iRowNo & ": Premium Amount " & getCellValue(sResourceSheet, iRowNo, 4) & " is not numeric, please have a check!"
    GoTo Err_Line
  End If

  '**Format Premium Amount to 0000XXX, length is 7, add char 0 in front of the amount
  sPremAmount = Right(String(7, "0") & nPremAmount * 100, 7)


  '**Generate Detail Record
  sDetailRecord = sDate + sTransCode & sPremAmount

  '**Accumulation total number and total premium amount
  iRecordCount = iRecordCount + 1
  nTotalPremAmount = nTotalPremAmount + nPremAmount

  '**Combine the row record and write into the text file
  Call objText.WriteLine(sDetailRecord)


'Next Record
  iRowNo = iRowNo + 1
Wend


'**Verify and Write the footer into the text file
sFooterTransCode = Left(UCase(getCellValue(sResourceSheet, iRowNo, 1)) & Space(5), 5)

sFiller2 = String(9, "9")

nFooterTotalAmount = getCellValue(sResourceSheet, iRowNo, 4)
'Total Amount, the length is 9
sFooterTotalAmount = Right("00000" & nFooterTotalAmount * 100, 9)


If Abs(nTotalPremAmount - nFooterTotalAmount) > 0.001 Then
    'Report Error
    sErrorMsg = "The footer total premium amount is not equal with the actual total premium! Please check it again!"
    GoTo Err_Line
End If

sFooterRecord = sFooterTransCode & sFiller2 &  sFooterTotalAmount

'**Insert the last row record and write into the text file
Call objText.WriteLine(sFooterRecord)

convertExcelToText = ""

Exit Function

Err_Line:


    If Err.Number = 0 Then

    convertExcelToText = sErrorMsg

    Else

    convertExcelToText = sErrorMsg & vbCrLf & _
            "Unexpected Error:" & Err.Number & "-" & Err.Description

    End If

    objText.Close

    'Remove the file to be generated
    Kill sFileName
    'fso.deletefile sFileName, force
    Exit Function