Excel VBA質問箱 IV

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

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


4907 / 13646 ツリー ←次へ | 前へ→

【53670】CSVデータの取込み時に、出力先(列の指定)をするには? GON 08/1/30(水) 16:29 質問[未読]
【53671】Re:CSVデータの取込み時に、出力先(列... Hirofumi 08/1/30(水) 19:41 回答[未読]
【53687】Re:CSVデータの取込み時に、出力先(列... GON 08/2/1(金) 14:04 お礼[未読]
【53673】Re:CSVデータの取込み時に、出力先(列... マルチーズ 08/1/30(水) 20:07 発言[未読]

【53670】CSVデータの取込み時に、出力先(列の...
質問  GON  - 08/1/30(水) 16:29 -

引用なし
パスワード
   はじめまして、GONです。
履歴をみてVBAを勉強しています。
CSVデータの扱いで、ご質問です。

【CSVファイルの例】
"A01","11","ABC","AAAAA","A01 A02 A03","ABCDE","1","1000"
"A02","21","ABC","AA","A01 A02","ABCDE","1","2000"
"A03","31","ABC","AAAAA","","ABCDE","1","3000"
"A04","41","ABC","AAAAA","A01","ABCDE","1","4000"
"A05","51","ABC","AAAAA","A01 A03","ABCDE","1","5000"

【このソースの結果】
 A  B C  D   E  F   G H
1 A01 11 ABC AAAAA A01 ABCDE 1 1000
          A02
          A03
2 A02 21 ABC AA  A01 ABCDE 1 1000
          A02
3 A03 31 ABC AAAAA   ABCDE 1 1000
4 A04 41 ABC AAAAA A01 ABCDE 1 1000
5 A05 51 ABC AAAAA A01 ABCDE 1 1000
          A03


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
  Dim blnStatusBar As Boolean
  Dim objFso As Object
 
  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path
  If Not GetReadFile(vntFileName, strPath) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '◆出力先頭セル位置を設定(基準セル位置)
  Set rngResult = ActiveSheet.Cells(1, "A")
  
  With Application
    '現状のステータスバーの状態を保存
    blnStatusBar = .DisplayStatusBar
    'ステータスバーを表示
    .DisplayStatusBar = True
    '画面更新を停止
    .ScreenUpdating = False
  End With
  
  'データの読み込み
  CSVRead vntFileName, rngResult, lngRow, 2

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

Wayout:

  Set rngResult = Nothing

  With Application
    '画面更新を再開
    .ScreenUpdating = True
    'ステータス バーの文字列を既定値に戻す
    .StatusBar = False
    'ステータス バーの設定を元に戻す
    .DisplayStatusBar = blnStatusBar
  End With

  MsgBox strProm, vbInformation

End Sub

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

'  strFileName:Csvのファイル名
'  rngWrite:出力基準位置、
'  lngRow:出力行位置
'  lngStart:Csv読み込み開始行

  Dim i As Long
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  
  'ファイルを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
      '読み込み行数のカウントをとる
      i = i + 1
      If i >= lngStart Then
        With rngWrite.Offset(lngRow)
          '出力範囲を文字列に設定
'          .Offset(, 1).Resize(, 2).NumberFormat = "@"
          '5列目の半角スペースをLfに置き換える
          On Error Resume Next
          vntField(4) = Replace(vntField(4), " ", vbLf, , , vbBinaryCompare)
          On Error GoTo 0
          'データを出力
          .Resize(, UBound(vntField) + 1).Value = vntField
        End With
        '出力行をインクリメント
        lngRow = lngRow + 1
      End If
      Application.StatusBar = "読み込み中です...." & i & " レコード目"
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbLf
    End If
  Loop

  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

というコード、CSVデータの項目毎に列を指定したい場合は
どのようになりますか?

1項目->A列、2項目->D列、3項目->C列 とか。

本見て調べてるんですが、よくわかりませんので教えてください。

【53671】Re:CSVデータの取込み時に、出力先(...
回答  Hirofumi  - 08/1/30(水) 19:41 -

引用なし
パスワード
   このコードでは、

    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti)

の所で上記の「vntField」と言う配列変数に、Csvの第1フィールドがvntField(0)、
第2フィールドがvntField(1)、第3フィールドがvntField(2)・・と言う形に入ります
そして、その「vntField」(1レコード分)を其のまま出力しています
そこで、質問の

>というコード、CSVデータの項目毎に列を指定したい場合は
>どのようになりますか?
>
>1項目->A列、2項目->D列、3項目->C列 とか。

と言う場合は、幾つかの方法が有りますが2つほど
1、新しい出力用配列を用意して、1レコード分づつその配列に変更指定順番に転記してそれを出力する
2、読み込み時には、そのまま読み込ませ、全てシートに出力し終わった時点で、
 最終行の下に変更する順の番号を出力して、其れをKeyとして列方向の整列を行い、整列後に整列Keyを削除

まず1を考えた場合、以下の様に成ります

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

'  strFileName:Csvのファイル名
'  rngWrite:出力基準位置、
'  lngRow:出力行位置
'  lngStart:Csv読み込み開始行

  Dim i As Long
  Dim j As Long '★追加
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  '読み込み順を指定する配列
  Dim vntOrder As Variant '★追加
  '出力用配列
  Dim vntResult As Variant '★追加
  
  '出力順を指定(1項目->A列、2項目->D列、3項目->C列)
  '出力用配列の頭から順にCsvのどの位置のフィールドを
  '持ってくるか指定する(ただし、-1は空欄とする)
  vntOrder = Array(0, -1, 2, 1) '★追加
  '出力用配列を確保
  ReDim vntResult(UBound(vntOrder)) '★追加
  
  i = 0 '★追加
  j = 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
      '読み込み行数のカウントをとる
      i = i + 1
      If i >= lngStart Then
        With rngWrite.Offset(lngRow)
          '出力範囲を文字列に設定
'          .Offset(, 1).Resize(, 2).NumberFormat = "@"
          '5列目の半角スペースをLfに置き換える
          On Error Resume Next
          vntField(4) = Replace(vntField(4), " ", vbLf, , , vbBinaryCompare)
          '列変更順に出力用配列に元データを代入
          For j = 0 To UBound(vntOrder) '★追加
            '空欄は飛ばす
            If vntOrder(j) > -1 Then '★追加
              vntResult(j) = vntField(vntOrder(j)) '★追加
            End If '★追加
          Next j '★追加
          On Error GoTo 0
          'データを出力
'          .Resize(, UBound(vntField) + 1).Value = vntField
          .Resize(, UBound(vntResult) + 1).Value = vntResult '★変更
        End With
        '出力行をインクリメント
        lngRow = lngRow + 1
      End If
      Application.StatusBar = "読み込み中です...." & i & " レコード目"
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbLf
    End If
  Loop

  Close #dfn

End Sub

【53673】Re:CSVデータの取込み時に、出力先(...
発言  マルチーズ  - 08/1/30(水) 20:07 -

引用なし
パスワード
   ここはマルチ禁止ではないが回答者への参考として。

http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200801/08010140.txt

【53687】Re:CSVデータの取込み時に、出力先(...
お礼  GON  - 08/2/1(金) 14:04 -

引用なし
パスワード
   ▼Hirofumi さん:
回答ありがとうございます。
とても参考になりました。
返信遅れてスミマセン、回答して頂いた内容をもとにテストしていたので...。


>このコードでは、
>
>    '論理レコードをフィールドに分割
>    vntField = SplitCsv(strRec, strDelim, , , blnMulti)
>
>の所で上記の「vntField」と言う配列変数に、Csvの第1フィールドがvntField(0)、
>第2フィールドがvntField(1)、第3フィールドがvntField(2)・・と言う形に入ります
>そして、その「vntField」(1レコード分)を其のまま出力しています
>そこで、質問の
>
>>というコード、CSVデータの項目毎に列を指定したい場合は
>>どのようになりますか?
>>
>>1項目->A列、2項目->D列、3項目->C列 とか。
>
>と言う場合は、幾つかの方法が有りますが2つほど
>1、新しい出力用配列を用意して、1レコード分づつその配列に変更指定順番に転記してそれを出力する
>2、読み込み時には、そのまま読み込ませ、全てシートに出力し終わった時点で、
> 最終行の下に変更する順の番号を出力して、其れをKeyとして列方向の整列を行い、整列後に整列Keyを削除
>
>まず1を考えた場合、以下の様に成ります
>
>Private Sub CSVRead(ByVal strFileName As String, _
>          ByRef rngWrite As Range, _
>          Optional ByRef lngRow As Long = 1, _
>          Optional ByVal lngStart As Long = 1, _
>          Optional strDelim As String = ",")
>
>'  strFileName:Csvのファイル名
>'  rngWrite:出力基準位置、
>'  lngRow:出力行位置
>'  lngStart:Csv読み込み開始行
>
>  Dim i As Long
>  Dim j As Long '★追加
>  Dim dfn As Integer
>  Dim vntField As Variant
>  Dim strBuff As String
>  Dim blnMulti As Boolean
>  Dim strRec As String
>  '読み込み順を指定する配列
>  Dim vntOrder As Variant '★追加
>  '出力用配列
>  Dim vntResult As Variant '★追加
>  
>  '出力順を指定(1項目->A列、2項目->D列、3項目->C列)
>  '出力用配列の頭から順にCsvのどの位置のフィールドを
>  '持ってくるか指定する(ただし、-1は空欄とする)
>  vntOrder = Array(0, -1, 2, 1) '★追加
>  '出力用配列を確保
>  ReDim vntResult(UBound(vntOrder)) '★追加
>  
>  i = 0 '★追加
>  j = 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
>      '読み込み行数のカウントをとる
>      i = i + 1
>      If i >= lngStart Then
>        With rngWrite.Offset(lngRow)
>          '出力範囲を文字列に設定
>'          .Offset(, 1).Resize(, 2).NumberFormat = "@"
>          '5列目の半角スペースをLfに置き換える
>          On Error Resume Next
>          vntField(4) = Replace(vntField(4), " ", vbLf, , , vbBinaryCompare)
>          '列変更順に出力用配列に元データを代入
>          For j = 0 To UBound(vntOrder) '★追加
>            '空欄は飛ばす
>            If vntOrder(j) > -1 Then '★追加
>              vntResult(j) = vntField(vntOrder(j)) '★追加
>            End If '★追加
>          Next j '★追加
>          On Error GoTo 0
>          'データを出力
>'          .Resize(, UBound(vntField) + 1).Value = vntField
>          .Resize(, UBound(vntResult) + 1).Value = vntResult '★変更
>        End With
>        '出力行をインクリメント
>        lngRow = lngRow + 1
>      End If
>      Application.StatusBar = "読み込み中です...." & i & " レコード目"
>      strRec = ""
>    Else
>      'セル内改行として残す場合
>      strRec = strRec & vbLf
>    End If
>  Loop
>
>  Close #dfn
>
>End Sub

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