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 件のコメント:
コメントを投稿