CSVデータをExcelファイルに取り込んで数式を設定するマクロ

 sqlite3のバッチで出力したCSVファイルを取り込んで、数式を設定し、一覧を作成するマクロを作成した。データも項目も適当・・・

・設定シート

・CSVデータ

・結果一覧

※設定シートの注文数×200を送金額という数式を設定してあって、数式を貼り付けているので結果一覧は計算された結果になっている
ソース
----------------------------------------------------------------------------

'最大で300項目まで処理
Private Const FINT_MAX_COL_COUNT As Integer = 300
Private Const FINT_CSV_DATA_STA_COLUMN As Integer = 3
Private Const FINT_CSV_DATA_STA_ROW As Integer = 4
Private Const FINT_TITLE_STA_COLUMN As Integer = 3
Private Const FINT_TITLE_STA_ROW As Integer = 5
Private Const FINT_DATA_STA_COLUMN As Integer = 3
Private Const FINT_DATA_STA_ROW As Integer = 6

Public Sub test()
    Application.ScreenUpdating = False
    
    Dim iMaxColumn As Integer
    iMaxColumn = GetMaxColumnCount(Sheet1.Name, FINT_TITLE_STA_ROW, FINT_TITLE_STA_COLUMN)
    Dim rdCsv As ADODB.Recordset
    Set rdCsv = New ADODB.Recordset
    'データ取り込み処理
    Call GetCsvData(rdCsv)
    Dim intColCount As Integer
    Dim iColTmp As Integer
    Dim rdResult As ADODB.Recordset
    Set rdResult = New ADODB.Recordset
    
    intColCount = iMaxColumn - FINT_TITLE_STA_COLUMN + 1
    ReDim strCsvDataColumnName(intColCount) As String
    ReDim strTitleDataColumnName(intColCount) As String
    For iColTmp = 0 To intColCount - 1
        strCsvDataColumnName(iColTmp) = ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_CSV_DATA_STA_ROW, FINT_CSV_DATA_STA_COLUMN + iColTmp)
        strTitleDataColumnName(iColTmp) = ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_TITLE_STA_ROW, FINT_TITLE_STA_COLUMN + iColTmp)
        rdResult.Fields.Append strTitleDataColumnName(iColTmp), adBSTR
    Next
    
    
    Dim iRowCnt As Long
    iRowCnt = 0
    rdResult.Open
    Do Until rdCsv.Eof
        rdResult.AddNew
        For iColTmp = 0 To intColCount - 1
            If strCsvDataColumnName(iColTmp) <> "" Then
                rdResult.Fields(strTitleDataColumnName(iColTmp)) = rdCsv.Fields(strCsvDataColumnName(iColTmp))
            Else
                rdResult.Fields(strTitleDataColumnName(iColTmp)) = ""
            End If
        Next
        rdResult.Update
        rdCsv.MoveNext
    Loop
    
    'データを削除する
    ThisWorkbook.Sheets(Sheet2.Name).Rows("1:100000").Delete
    'データを書き出す
    rdResult.MoveFirst
'    見出しは後で貼り付ける
'    For iColTmp = 1 To rdResult.Fields.Count
'        ThisWorkbook.Sheets(Sheet2.Name).Cells(1, iColTmp) = rdResult.Fields(iColTmp - 1).Name
'    Next
    ThisWorkbook.Sheets(Sheet2.Name).Range("A2").CopyFromRecordset rdResult
    
    Dim strRange As String
    Dim strRangeSta As String
    
    'タイトルを貼り付ける
    strRangeSta = Replace(Replace(ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_TITLE_STA_ROW, FINT_TITLE_STA_COLUMN).Address, "$" & FINT_TITLE_STA_ROW, ""), "$", "")
    strRange = Replace(Replace(ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_TITLE_STA_ROW, iMaxColumn).Address, "$" & FINT_TITLE_STA_ROW, ""), "$", "")
    ThisWorkbook.Sheets(Sheet1.Name).Range(strRangeSta & FINT_TITLE_STA_ROW & ":" & strRange & FINT_TITLE_STA_ROW).Copy
    ThisWorkbook.Sheets(Sheet2.Name).Select
    ThisWorkbook.Sheets(Sheet2.Name).Range("A1").Select
    ActiveSheet.Paste
    
    'データの書式を貼り付ける
    ThisWorkbook.Sheets(Sheet1.Name).Select
    ThisWorkbook.Sheets(Sheet1.Name).Range(strRangeSta & FINT_DATA_STA_ROW & ":" & strRange & FINT_DATA_STA_ROW).Copy
    strRange = Replace(Replace(ThisWorkbook.Sheets(Sheet2.Name).Cells(1, intColCount).Address, "$1", ""), "$", "")
    ThisWorkbook.Sheets(Sheet2.Name).Select
    ThisWorkbook.Sheets(Sheet2.Name).Range("A2:" & strRange & CLng(rdResult.RecordCount + 1)).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
    '数式を貼り付ける
    For iColTmp = 0 To intColCount - 1
        If strCsvDataColumnName(iColTmp) = "" Then
            strRange = Replace(Replace(ThisWorkbook.Sheets(Sheet2.Name).Cells(1, iColTmp + 1).Address, "$1", ""), "$", "")
            
            ThisWorkbook.Sheets(Sheet1.Name).Cells(FINT_DATA_STA_ROW, FINT_DATA_STA_COLUMN + iColTmp).Copy
            ThisWorkbook.Sheets(Sheet2.Name).Select
            ThisWorkbook.Sheets(Sheet2.Name).Range(strRange & "2:" & strRange & CLng(rdResult.RecordCount + 1)).Select
            Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    
    Next
    Application.ScreenUpdating = True
    
End Sub

'最大の列番号を取得する
Private Function GetMaxColumnCount(ByVal strSheetName As String, ByVal intStaCol As Integer, ByVal intStaRow As Integer) As Integer
    ThisWorkbook.Sheets(strSheetName).Select
    ThisWorkbook.Sheets(strSheetName).Cells(intStaCol, intStaRow).Select
    Selection.End(xlToRight).Select
    GetMaxColumnCount = Selection.Column
End Function

Public Sub GetCsvData(ByRef rdData As ADODB.Recordset)
    Dim varFileName As Variant
    Dim intFree As Integer
    Dim strRec As String
    Dim strSplit() As String
    Dim i As Long, j As Long, k As Long
    Dim lngQuote As Long
    Dim strCell As String
    varFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", _
                                                Title:="CSVファイルの選択")
    If varFileName = False Then
        Exit Sub
    End If
'    intFree = FreeFile '空番号を取得
'    Open varFileName For Input As #intFree 'CSVファィルをオープン
  
    Dim rdReturn As ADODB.Recordset
    Set rdReturn = New ADODB.Recordset
    Dim blnFirst As Boolean
    blnFirst = True
    i = 0
    Dim itemCount As Integer
    
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile varFileName
        
        Do While Not (.EOS)
            strRec = .ReadText(adReadLine)
            i = i + 1
            j = 0
            lngQuote = 0
            itemCount = 0
            strCell = ""
            
            If blnFirst = False Then rdReturn.AddNew
                            
            For k = 1 To Len(strRec)
                Select Case Mid(strRec, k, 1)
                    Case "," '「"」が偶数なら区切り、奇数ならただの文字
                        If lngQuote Mod 2 = 0 Then
                            'Call PutCell(i, j, strCell, lngQuote)
                            If blnFirst = True Then
                                rdReturn.Fields.Append ConvertValue(strCell, lngQuote), adBSTR
                            Else
                                'データを格納
                                rdReturn.Fields(itemCount) = ConvertValue(strCell, lngQuote)
                                itemCount = itemCount + 1
                            End If
                        Else
                            strCell = strCell & Mid(strRec, k, 1)
                        End If
                    Case """" '「"」のカウントをとる
                        lngQuote = lngQuote + 1
                        strCell = strCell & Mid(strRec, k, 1)
                    Case Else
                        strCell = strCell & Mid(strRec, k, 1)
                End Select
            Next
            '最終列の処理
            
            If blnFirst = True Then
                rdReturn.Fields.Append ConvertValue(strCell, lngQuote), adBSTR
                blnFirst = False
                rdReturn.Open
            Else
                'データを格納
                rdReturn.Fields(itemCount) = ConvertValue(strCell, lngQuote)
                itemCount = itemCount + 1
                rdReturn.Update
            End If
            
        Loop
        
        .Close
        
    End With
    
    rdReturn.MoveFirst
    
    'ThisWorkbook.Sheets(Sheet3.Name).Range("A2").CopyFromRecordset rdReturn
    Set rdData = rdReturn
    
End Sub
Function ConvertValue(ByRef strCell As String, ByRef lngQuote As Long) As String
    j = j + 1
    '「""」を「"」で置換
    strCell = Replace(strCell, """""", """")
    '前後の「"」を削除
    If strCell = """" Then
        strCell = ""
    ElseIf Left(strCell, 1) = """" And Right(strCell, 1) = """" Then
        strCell = Mid(strCell, 2, Len(strCell) - 2)
    End If
    ConvertValue = strCell
    strCell = ""
    lngQuote = 0
End Function