Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


22716 / 76738 ←次へ | 前へ→

【59400】Re:でっかいCSVをExcelでサクッと開きたい
発言  Hirofumi  - 08/12/9(火) 21:43 -

引用なし
パスワード
   此の方が気分速いかな?

Option Explicit

Public Sub DataRead()

  Dim i As Long
  Dim vntFileName As Variant
  Dim lngRow As Long
  Dim strPath As String
  Dim rngResult As Range
  Dim strProm As String
  
  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path
  vntFileName = "test"
  If Not GetReadFile(vntFileName, strPath) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '◆出力先頭セル位置を設定(基準セル位置)
  Set rngResult = ActiveSheet.Cells(1, "A")
  
  '画面更新を停止
  Application.ScreenUpdating = False
    
  'データの読み込み
  CSVRead vntFileName, rngResult, lngRow

  strProm = "処理が完了しました"

Wayout:

  Set rngResult = Nothing

  '画面更新を再開
  Application.ScreenUpdating = True

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          ByRef rngWrite As Range, _
          Optional ByRef lngRow As Long = 1, _
          Optional strDelim As String = ",")

  '1回の出力行数
  Const clngOutput As Long = 30
  
  Dim i As Long
  Dim vntResult As Variant
  Dim lngCount As Long
  Dim dfn As Integer
  Dim vntField As Variant
  Dim lngColumns As Long
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  
  '出力用配列確保
  ReDim vntResult(1 To clngOutput, 0)
  
  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti)
    'フィールド内で改行が無い場合
    If Not blnMulti Then
      lngColumns = UBound(vntField)
      '出力行数に達した場合
      If lngCount = clngOutput Then
        'データを出力
        With rngWrite.Offset(lngRow)
          '出力範囲を文字列に設定
'          .Resize(lngCount, UBound(vntResult, 2) + 1).NumberFormat = "@"
          'データを出力
          .Resize(lngCount, UBound(vntResult, 2) + 1).Value = vntResult
        End With
        lngRow = lngRow + clngOutput
        lngCount = 0
      End If
      lngCount = lngCount + 1
      If UBound(vntResult, 2) < lngColumns Then
        ReDim Preserve vntResult(1 To clngOutput, lngColumns)
      End If
      For i = 0 To lngColumns
        vntResult(lngCount, i) = vntField(i)
      Next i
      For i = lngColumns + 1 To UBound(vntResult, 2)
        vntResult(lngCount, i) = Empty
      Next i
      strRec = ""
    Else
      'セル内改行として残す場合
'      strRec = strRec & vbLf
      strRec = strRec & " "
    End If
  Loop
  
  If lngColumns > 0 Then
    With rngWrite.Offset(lngRow)
      '出力範囲を文字列に設定
'      .Resize(lngCount, UBound(vntResult, 2) + 1).NumberFormat = "@"
      'データを出力
      .Resize(lngCount, UBound(vntResult, 2) + 1).Value = vntResult
    End With
  End If
  
  Close #dfn

End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

  Dim i As Long
  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim vntField As Variant
  Dim lngLength As Long

  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart)
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    i = i + 1
  Loop Until lngLength < lngStart

  SplitCsv = vntData()

End Function

Private Function GetReadFile(vntFileNames As Variant, _
            Optional strFilePath As String, _
            Optional blnMultiSel As Boolean _
                    = False) As Boolean

  Dim strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function
0 hits

【59391】でっかいCSVをExcelでサクッと開きたい りった 08/12/9(火) 17:08 質問
【59395】Re:でっかいCSVをExcelでサクッと開きたい n 08/12/9(火) 18:38 発言
【59396】Re:でっかいCSVをExcelでサクッと開きたい kanabun 08/12/9(火) 18:47 発言
【59400】Re:でっかいCSVをExcelでサクッと開きたい Hirofumi 08/12/9(火) 21:43 発言
【59407】Re:でっかいCSVをExcelでサクッと開きたい Yuki 08/12/10(水) 8:44 発言
【59415】全部に返信 りった 08/12/10(水) 16:08 発言
【59416】┏(;〃。_ 。〃)┓すみません りった 08/12/10(水) 16:43 発言
【59419】Re:┏(;〃。_ 。〃)┓すみません neptune 08/12/10(水) 17:01 発言
【59451】Re:┏(;〃。_ 。〃)┓すみません りった 08/12/11(木) 17:16 発言
【59544】ヘ(´_`)ヘ りった 08/12/17(水) 20:12 お礼
【59418】Re:全部に返信 neptune 08/12/10(水) 16:55 発言

22716 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free