フリーソフト

以下コピーしてお使いください。

		
Option Explicit


'-------------------------------------------------------------------------------------------
'出力された検索結果のCSVファイルをシート(1)に読み込みます
'※シート内容は消去されます
'60000行を超えた場合は新しいシートを追加して続きを読み込みます
'列データは以下の通り
'型番,検索ワード,検索ヒット数,順位,販売価格,送料情報,ポイント倍率,店名,商品名,商品ページURL
'起動方法は、特に設定していませんので、ボタンに登録するなり、マクロメニューから実行するなりして下さい
'エンクォートされた文字列中の"処理を修正
'-------------------------------------------------------------------------------------------
Public Sub loadCsvForRakutenBig()
    Dim loadFileName    As String
    Dim b_buf()         As Byte
    Dim s_buf           As String
    Dim tmp             As Variant
    Dim tmp2            As Variant
    Dim tmp3            As Variant
    Dim i               As Long
    Dim j               As Long
    Dim maxRow          As Long
    Dim columnWidth()   As Variant
    Dim hyperColumn     As Integer
    Dim crlfColumn      As Integer
    Dim addCnt          As Integer
    Dim sRow            As Long
    Dim nowSheetName    As String
    Dim nowSheetCount   As Integer
    Dim nowSheet        As Worksheet
    Dim checkRow        As Long
    Dim sheetLimit      As Long
    Dim nextInfo        As Boolean
    Dim tmpStr  As String
    Dim tmpRank As Integer
    Dim maxCol  As Long

    nowSheetCount = 1
    nowSheetName = "Sheet" & nowSheetCount
    sheetLimit = 60000  'シートを分割する行数（データにより60000＋αで分割されます）設定は変更可能（21行以上）
    'ハイパーリンクをつける列番号を指
    hyperColumn = 11
    'Yahoo専用pathカラム（改行コード対処）
    crlfColumn = 16
    '列幅指定（数値は列幅サイズ、Autoは自動で列幅を設定させる場合）
    'シートを見やすくするためA列、B列、I列以外を自動調整させています
    columnWidth = Array("20", "20", "Auto", "Auto", "Auto", "Auto", "Auto", "Auto", "30", "50", "Auto")

    '指定のCSVをSheetに読み込みます
    loadFileName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv" & ",テキストファイル(*.txt),*.txt" _
           , FilterIndex:=1 _
           , Title:="読み込むCSVデータ" _
           , MultiSelect:=False _
            )
    If loadFileName = "False" Then
        MsgBox "キャンセルしました"
        Exit Sub
    Else
        Application.ScreenUpdating = False
        Application.StatusBar = "CSVをバッファに読み込み中… "
        Open loadFileName For Binary As #1
            ReDim b_buf(1 To LOF(1))
            Get #1, 1, b_buf
        Close #1
        s_buf = StrConv(b_buf, vbUnicode)                   'Change Unicode
        tmp = Split(s_buf, vbCrLf)

        If SheetExistCheckWithBook(nowSheetName) Then
            ThisWorkbook.Sheets(nowSheetName).Cells.Clear
        Else
            Set nowSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            nowSheet.Name = nowSheetName
        End If
        
        maxRow = UBound(tmp)
        checkRow = 1
        nowSheetCount = 1
        nextInfo = False
        Do
            'シートの準備
            Application.StatusBar = "シートの追加中… "
            nowSheetName = "Sheet" & nowSheetCount
            If SheetExistCheckWithBook(nowSheetName) Then
                ThisWorkbook.Sheets(nowSheetName).Cells.Clear
                Set nowSheet = ThisWorkbook.Sheets(nowSheetName)
            Else
                Set nowSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                nowSheet.Name = nowSheetName
            End If
            nowSheet.Rows(1).RowHeight = 20     '1行目はボタンのため高さを20にする
            '1行目のみヘッダ処理→"が付いてない!
            sRow = 1
            tmp2 = Split(tmp(0), ",")
            For i = 0 To UBound(tmp2)
                nowSheet.Cells(sRow, i + 1).Value = tmp2(i)
            Next i
            maxCol = UBound(tmp2) + 1
            '2行目以降
            sRow = 2
            tmp3 = tmp
            For i = checkRow To maxRow - 1
                addCnt = 0
                Application.StatusBar = "CSVを解析&読込中… " & i & "/" & maxRow & "行目"
                DoEvents
                tmp3(i) = Mid(tmp3(i), 2)
                If Right(tmp3(i), 1) <> """" Then
                    '改行ありコード
                    Do
                        addCnt = addCnt + 1
                        tmp3(i) = tmp3(i) & vbCrLf & tmp(i + addCnt)
                    Loop While (Right(tmp3(i), 1) <> """")
                End If
                tmp3(i) = Left(tmp3(i), Len(tmp3(i)) - 1)   '末尾の「"」カット
                tmp2 = Split(tmp3(i), """,""")
                For j = 0 To UBound(tmp2)
                    nowSheet.Cells(sRow, j + 1).Value = Replace(tmp2(j), """""", """")
                Next j
                i = i + addCnt
                'ハイパーリンクをつけます
                nowSheet.Hyperlinks.Add Anchor:=nowSheet.Cells(sRow, hyperColumn), Address:=nowSheet.Cells(sRow, hyperColumn)
                nowSheet.Cells(sRow, 1).NumberFormatLocal = "0_ "
                '商品毎に初めの行に色を付けます
                If nowSheet.Cells(sRow, 4).Value = 1 Then
                    nowSheet.Range(nowSheet.Cells(sRow, 1), nowSheet.Cells(sRow, maxCol)).Interior.ColorIndex = 34       '薄い水色
                End If
                'Limit Check
                If nowSheet.Cells(sRow, 4).Value = 1 And sRow > sheetLimit Then
                    nowSheetCount = nowSheetCount + 1      'Next Sheet
                    checkRow = checkRow + sRow - 2         '次のシートに再度入れなおすためインデックス戻し
                    nowSheet.Range(nowSheet.Cells(sRow, 1), nowSheet.Cells(sRow, maxCol)).Interior.Color = xlNone   '色抜き
                    nowSheet.Range(nowSheet.Cells(sRow, 1), nowSheet.Cells(sRow, maxCol)).Clear
                    nextInfo = True
                    Exit For
                Else
                    sRow = sRow + 1
                End If
            Next i
            If nextInfo = False Then
                checkRow = i - 1
            Else
                nextInfo = False
            End If
            nowSheet.Cells.WrapText = False                                      '折り返し無し
            '列幅を設定して見やすくします
            For i = 0 To UBound(columnWidth)
                Application.StatusBar = "シートの列幅調整中… " & i & "/" & UBound(columnWidth) & "列目"
                DoEvents
                If columnWidth(i) = "Auto" Then
                    nowSheet.Columns(i + 1).Columns.AutoFit
                Else
                    nowSheet.Columns(i + 1).columnWidth = columnWidth(i)
                End If
            Next i
        Loop While (checkRow < maxRow - 1)
    End If
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Sheet Exist Check
'指定のシート名のシートがマクロブックにあるかどうかチェックする
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Private Function SheetExistCheckWithBook(ByVal sheetName As String) As Boolean
    Dim sh As Worksheet
    Dim sExist As Boolean

    sExist = False
    For Each sh In ThisWorkbook.Worksheets
        If LCase(sh.Name) = LCase(sheetName) Then
            sExist = True
            Exit For
        End If
    Next sh
    SheetExistCheckWithBook = sExist
End Function