Excel VBA質問箱 IV

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

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


66978 / 76734 ←次へ | 前へ→

【14315】Re:CSVファイルを読み込む
回答  Hirofumi E-MAIL  - 04/5/25(火) 21:05 -

引用なし
パスワード
   チョット違うけど、こんなのも有るよ
CsvDataReadと言うマクロを実行すると「フォーマット.xls」がOpenされ
「ファイルを開く」ダイアログが表示されます
ここで、Csvファイルをを複数選択すると、選択されたファイルが
「フォーマット.xls」にシートが追加され、1シート1ファイルとして、
其処へ読み込まれます
「実行ファイルという名のExcelのブック」のコマンドボタンで「Sub CsvDataRead」を
実行する様にして下さい
また、「フォーマット.xls」の有る場所は、現状のコードでは、
「実行ファイルという名のExcelのブック」と同じフォルダとしていますので
これは実状に合わせて下さい

Option Explicit

Public Sub CsvDataRead()

  Dim i As Long
  Dim vntFileNames As Variant
  Dim lngWriteRow As Long
  Dim wksWrite As Worksheet
  Dim strPath As String
  Dim strSheetName As String
  
  'Csvファイルを読み込むBookをOpen
  Workbooks.Open ThisWorkbook.Path _
          & "\" & "フォーマット.xls"
  
  'Csvファイルの有るフォルダを指定
  strPath = ActiveWorkbook.Path
'  strPath = "D:\Data Folder"
  '「ファイルを開く」ダイアログを複数選択で表示
  If Not GetReadFile(vntFileNames, strPath, True) Then
    Exit Sub
  End If
  
'  Application.ScreenUpdating = False
    
  '複数選択されたファイルをシートに出力
  For i = 1 To UBound(vntFileNames)
    'シート名を作成
    strSheetName _
      = GetFileName(vntFileNames(i))
    strSheetName _
      = GetSheetName(strSheetName)
    'アクティブBookにシートを追加
    With ActiveWorkbook.Worksheets
      '出力シートを設定
      Set wksWrite _
        = .Add(After:=Worksheets(.Count))
    End With
    'シート名を変更
    wksWrite.Name = strSheetName
    '出力する先頭行を設定
    lngWriteRow = 1
    'CSVを書き込み
    CSVRead vntFileNames(i), _
          wksWrite, lngWriteRow, 1
'    wksWrite.Columns.AutoFit
  Next i
  
  Set wksWrite = Nothing
  
'  Application.ScreenUpdating = True
  
  Beep
  MsgBox "処理が完了しました"
  
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal wksWrite As Worksheet, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1)
  
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  
  '空きファイルバファ番号を取得
  dfn = FreeFile
  'ファイルをInputモードで開く
  Open strFileName For Input As dfn
  
  'ファイルエンドまで繰り返し
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    'レコードをフィールドに分割
    vntField = SplitCsv(strBuff, ",", , , blnMulti)
    '物理レコードに改行が有った場合
    If blnMulti Then
      strRec = strRec & vbLf
    Else
      '指定シートの指定列、行について
      With wksWrite.Cells(lngRow, lngCol)
        '結果配列を代入
        .Offset.Resize(, UBound(vntField) + 1) = vntField
      End With
      '書き込み行を更新
      lngRow = lngRow + 1
      '論理レコードをクリア
      strRec = ""
    End If
  Loop
  
  'ファイルをClose
  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 lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As String
  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)
        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) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = ""
    i = i + 1
  Loop Until lngLength < lngStart
  
  SplitCsv = vntData()
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
          Optional strFilePath As String, _
          Optional blnMulti 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, False
  End If
  
  vntFileNames _
    = Application.GetOpenFilename(strFilter, 1, , , blnMulti)
  If Not VarType(vntFileNames) = vbBoolean Then
    GetReadFile = True
  End If
  
End Function

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt"
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  '「ファイルを保存」ダイアログを表示
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function

Private Function GetSheetName(ByVal strName As String, _
        Optional ByVal wkbBook As Workbook) As String

'  同一シート名の存在確認と枝番付加

  Dim i As Long
  Dim lngPos As Long
  Dim lngNumb As Long
  Dim lngTmpNumb As Long
  Dim strSName As String
  
  If wkbBook Is Nothing Then
    Set wkbBook = ThisWorkbook
  End If
  
  lngPos = Len(strName) + 1
  lngNumb = -1
  With wkbBook
    For i = 1 To .Worksheets.Count
      strSName = .Worksheets(i).Name
      If strSName Like strName & "*" Then
        Select Case Mid(strSName, lngPos, 1)
          Case ""
            lngTmpNumb = 0
          Case "("
            lngTmpNumb _
                = InStr(1, strSName, ")", _
                        vbBinaryCompare)
            If lngTmpNumb > 0 Then
              lngTmpNumb _
                = Val(Mid(strSName, lngPos + 1, _
                    lngTmpNumb - lngPos - 1))
            Else
              lngTmpNumb _
                = Val(Mid(strSName, lngPos + 1))
            End If
          Case Else
            lngTmpNumb = -1
        End Select
        If lngNumb < lngTmpNumb Then
          lngNumb = lngTmpNumb
        End If
      End If
    Next i
  End With
  
  Set wkbBook = Nothing
  
  If lngNumb = -1 Then
    GetSheetName = strName
  Else
    GetSheetName = strName & "(" & (lngNumb + 1) & ")"
  End If

End Function

Private Function GetFileName(ByVal strName As String) As String

'  ファイル名をPathから分離

  Dim i As Long
  Dim lngPos As Long
  
  i = 0
  lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, "\", vbBinaryCompare)
  Loop
  strName = Mid(strName, i + 1)
  
  i = 1
  lngPos = InStr(i, strName, ".", vbBinaryCompare)
  Do Until lngPos = 0
    i = lngPos
    lngPos = InStr(i + 1, strName, ".", vbBinaryCompare)
  Loop
  
  GetFileName = Left(strName, i - 1)
  
End Function
1 hits

【14281】CSVファイルを読み込む アスキー 04/5/25(火) 14:45 質問
【14284】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 15:20 回答
【14291】Re:CSVファイルを読み込む アスキー 04/5/25(火) 15:43 発言
【14294】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 15:51 発言
【14295】Re:CSVファイルを読み込む アスキー 04/5/25(火) 16:07 質問
【14299】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 16:26 回答
【14306】Re:CSVファイルを読み込む アスキー 04/5/25(火) 17:01 回答
【14307】Re:CSVファイルを読み込む ちゃっぴ 04/5/25(火) 17:11 回答
【14310】Re:CSVファイルを読み込む アスキー 04/5/25(火) 18:16 発言
【14312】Re:CSVファイルを読み込む [名前なし] 04/5/25(火) 18:59 回答
【14315】Re:CSVファイルを読み込む Hirofumi 04/5/25(火) 21:05 回答
【14317】Re:CSVファイルを読み込む Hirofumi 04/5/25(火) 21:44 回答
【14399】Re:CSVファイルを読み込む アスキー 04/5/28(金) 9:11 発言
【14517】Re:CSVファイルを読み込む アスキー 04/5/31(月) 17:50 質問
【14527】Re:CSVファイルを読み込む Hirofumi 04/5/31(月) 20:33 発言
【14536】Re:CSVファイルを読み込む アスキー 04/6/1(火) 1:33 質問
【14562】Re:CSVファイルを読み込む Hirofumi 04/6/1(火) 22:43 回答
【14573】Re:CSVファイルを読み込む アスキー 04/6/2(水) 10:11 質問
【14598】Re:CSVファイルを読み込む アスキー 04/6/2(水) 17:38 発言
【14603】Re:CSVファイルを読み込む Hirofumi 04/6/2(水) 21:11 回答
【14632】Re:CSVファイルを読み込む アスキー 04/6/3(木) 12:42 お礼

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