I must export data which over 256 columns to CSV File on Excel for SPSS(PASW).
So I coded By VBA.
'**************************************************
'
' ファイルを編集する
' @return void
' @exception
'
'**************************************************
Public Function GetFreeFileNumber(argExecutedPoint As String, argEditTypeLabel As String, argFilePath As String) As Long
Dim executedPoint As String
executedPoint = argExecutedPoint & FPR_MODULE_NAME & "EditFile"
On Error GoTo ERROR_STEP:
'//////////////////////////////////////// specific //////////////////////////////////////////////////////////
Dim freeFileNumber As Long
Dim isOpened As Boolean
Call RaiseErrorObjectWhenNoUpperDir(executedPoint, "argFilePath", argFilePath)
freeFileNumber = FreeFile
Select Case argEditTypeLabel
Case "create"
Call RaiseErrorObjectWhenSameNameFileExist(executedPoint, "argFilePath", argFilePath)
Case "overwrite", "add"
Call RaiseErrorObjectWhenNoFile(executedPoint, "argFilePath", argFilePath)
Case "createOrOverwrite", "createOrAppendText"
Case Else
Call RaiseErrorObjectOfInvalidArgument(executedPoint, "argEditTypeLabel" & argEditTypeLabel)
End Select
isOpened = True
Select Case argEditTypeLabel
Case "create", "overwrite", "createOrOverwrite"
Open argFilePath For Output Lock Read Write As #freeFileNumber
Case "add", "createOrAppendText"
Open argFilePath For Append Lock Read Write As #freeFileNumber
Case Else
isOpened = False
End Select
GetFreeFileNumber = freeFileNumber
'//////////////////////////////////////// specific //////////////////////////////////////////////////////////
Exit Function
ERROR_STEP:
If True = isOpened Then
Close #freeFileNumber
End If
Call ReRaiseErrorObject(executedPoint, Err)
End Function
'**************************************************
'
' CSV用に値を修正する
' @return void
' @exception
'
'**************************************************
Public Sub ModifyValueForCSV(argExecutedPoint As String, ByRef argValueRef As String)
Dim executedPoint As String
executedPoint = argExecutedPoint & FPR_MODULE_NAME & "ModifyValueForCSV"
On Error GoTo ERROR_STEP:
'//////////////////////////////////////// specific //////////////////////////////////////////////////////////
Dim doAddQuote As Boolean
argValueRef = Replace(argValueRef, """", """""")
If 0 <> InStr(argValueRef, ",") Then
doAddQuote = True
Else
If False = IsNumeric(argValueRef) And 0 <> Len(argValueRef) Then
doAddQuote = True
End If
End If
If True = doAddQuote Then
argValueRef = """" & argValueRef & """"
End If
'//////////////////////////////////////// specific //////////////////////////////////////////////////////////
Exit Sub
ERROR_STEP:
Call ReRaiseErrorObject(executedPoint, Err)
End Sub
'**************************************************
'
' ファイルを編集する
' @return void
' @exception
'
'**************************************************
Public Sub EditCSVFileByDM2Array(argExecutedPoint As String, argEditTypeLabel As String, argFilePath As String, ByRef argArrContentsRef As Variant)
Dim executedPoint As String
executedPoint = argExecutedPoint & FPR_MODULE_NAME & "EditCSVFileByDM2Array"
On Error GoTo ERROR_STEP:
'//////////////////////////////////////// specific //////////////////////////////////////////////////////////
Dim freeFileNumber As Long
Dim isOpened As Boolean
Dim objSize As New AggregationSizeClass
Dim arrSize() As aggregationSizeType
Dim i As Long
Dim j As Long
Dim tmpContents As String
Dim tmpArrOneLine() As String
freeFileNumber = GetFreeFileNumber(executedPoint, argEditTypeLabel, argFilePath)
isOpened = True
arrSize = objSize.GetSizeArrayOfDM2Aggregation(executedPoint, argArrContentsRef)
ReDim tmpArrOneLine(arrSize(2).lastIndex)
For i = arrSize(1).firstIndex To arrSize(1).lastIndex
For j = arrSize(2).firstIndex To arrSize(2).lastIndex
tmpContents = argArrContentsRef(i, j)
Call ModifyValueForCSV(executedPoint, tmpContents)
tmpArrOneLine(j) = tmpContents
Next j
Print #freeFileNumber, Join(tmpArrOneLine, ",")
Next i
Close #freeFileNumber
isOpened = False
'//////////////////////////////////////// specific //////////////////////////////////////////////////////////
Exit Sub
ERROR_STEP:
If True = isOpened Then
Close #freeFileNumber
End If
Call ReRaiseErrorObject(executedPoint, Err)
End Sub
0 件のコメント:
コメントを投稿