Excel VBA質問箱 IV

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

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


38028 / 76732 ←次へ | 前へ→

【43848】Re:複雑な(?)転記
回答  Hirofumi  - 06/10/26(木) 20:22 -

引用なし
パスワード
   こんなので、CSVから直接Sheet3の表に読み込むと思います
一応、コード中の下記の部分の設定を替えて試して見て下さい

  '出力する表の行数
  Const clngListCount As Long = 20
  '表の列ピッチを設定(出力する表が何列置きに有るのかを設定)
  Const clngColPitch As Long = 4
  '表の行ピッチを設定(出力する表が何行置きに有るのかを設定)
  Const clngRowPitch As Long = 22
  '表が横方向に何枚並ぶのかを設定(設定例は横に5枚の表が並ぶ)
  Const clngMaxSet As Long = 5
  
  '出力するCsvの列を出力する順に設定
  '例えば、Csvの列が5列の場合、先頭列は0番、最終列は4番と成る
  '例では、ID=4、名前=0、電話=2と成る
  vntPos = Array(4, 0, 2)
  
  '出力先頭セル位置を設定(基準セル位置)
  Set rngResult = Worksheets("Sheet3").Cells(2, "A")

この設定例では、データ行が20行の表が、Sheet3のA2をデータの先頭として有る物としています
また、データがこの表からはみ出した場合、右側の表に出力していきます、此れが5枚を越した場合
最初の表の下2行を空けて次の表が書かれて行きます
詰まり、Z型に出力されます

下記もコードを標準モジュールに記述して下さい

Option Explicit

Public Sub DataRead()

  '出力する表の行数
  Const clngListCount As Long = 20
  '表の列ピッチを設定(出力する表が何列置きに有るのかを設定)
  Const clngColPitch As Long = 4
  '表の行ピッチを設定(出力する表が何行置きに有るのかを設定)
  Const clngRowPitch As Long = 22
  '表が横方向に何枚並ぶのかを設定(設定例は横に5枚の表が並ぶ)
  Const clngMaxSet As Long = 5
  
  Dim i As Long
  Dim lngCount As Long
  Dim dfn As Integer
  Dim vntFileName As Variant
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim lngRow As Long
  Dim rngResult As Range
  Dim lngRowOffset As Long
  Dim lngColOffset As Long
  Dim vntPos As Variant
  Dim vntResult As Variant
  Dim strProm As String

  '出力するCsvの列を出力する順に設定
  '例えば、Csvの列が5列の場合、先頭列は0番、最終列は4番と成る
  '例では、ID=4、名前=0、電話=2と成る
  vntPos = Array(4, 0, 2)
  
  '出力先頭セル位置を設定(基準セル位置)
  Set rngResult = Worksheets("Sheet3").Cells(2, "A")

  '読み込むファイルを取得
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '画面更新を停止
  Application.ScreenUpdating = False

  '出力行初期値(基準セル位置からの行Offset)
  lngRow = 0

  'データの読み込み
  'ファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, ",", , , blnMulti)
    'フィールド内で改行が有る場合
    If Not blnMulti Then
      '出力する配列を確保
      ReDim vntResult(0 To UBound(vntPos))
      'Csvのフィールド配列を出力配列に転記
      On Error Resume Next
      For i = 0 To UBound(vntPos)
        vntResult(i) = vntField(vntPos(i))
      Next i
      On Error GoTo 0
      '出力行位置を計算
      lngRow = lngCount Mod clngListCount
      '何処の表に出力するかを計算
      lngColOffset = ((lngCount \ clngListCount) _
                Mod clngMaxSet) * clngColPitch
      lngRowOffset = ((lngCount \ clngListCount) _
                \ clngMaxSet) * clngRowPitch
      '出力する表を選択
      With rngResult.Offset(lngRowOffset, lngColOffset)
        'データを出力
        .Offset(lngRow).Resize(, _
            UBound(vntResult) + 1).Value = vntResult
      End With
      '処理行数をインクリメント
      lngCount = lngCount + 1
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbLf
    End If
  Loop

  Close #dfn

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

Wayout:

  Set rngResult = Nothing

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

  MsgBox strProm, vbInformation

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

【43785】複雑な(?)転記 更夜 06/10/25(水) 17:33 質問
【43786】Re:複雑な(?)転記 ゆと 06/10/25(水) 18:09 発言
【43788】Re:複雑な(?)転記 ゆと 06/10/25(水) 19:05 発言
【43818】Re:複雑な(?)転記 更夜 06/10/26(木) 11:48 発言
【43848】Re:複雑な(?)転記 Hirofumi 06/10/26(木) 20:22 回答
【43945】Re:複雑な(?)転記 更夜 06/10/30(月) 15:20 お礼

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