Excel VBA質問箱 IV

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

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


60676 / 76738 ←次へ | 前へ→

【20699】Re:表へのCSVデータ挿入について
回答  Hirofumi  - 04/12/15(水) 21:17 -

引用なし
パスワード
   条件としては、
タグNo.は、既に1つ以上昇順に書き込んで有る事とします
もし、タグNo.が無い場合、昇順位置に行を挿入して書きこまれますが
既に書き込んで有った方が行挿入が行われませんので早く成ります
日付は、既に書き込んで無くてもファイルの値を書き込みます
ただし、タグNo.と同様既に書き込んで有った方が早く成ります
また、書き込む場合、左から右に昇順とします
日付、タグNoともに、昇順で書かれていない場合、結果は出鱈目に成ると思います
書き込む表をActiveSheetとして、マクロを実行して下さい
ファイルには、列見出しが無い物とします

Option Explicit

Public Sub PutData2()

  Dim vntFileName As Variant
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim lngCol As Long
  Dim lngRow As Long
  Dim rngScope As Range
  Dim rngResult As Range
  Dim rngDate As Range
  Dim blnWayOut As Boolean
  
  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "A")
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column
    '日付の有る範囲を取得
    If lngCol = 0 Then
      '指定されたファイルをOpen
      '日付の列が1つも無い場合後の処理が面倒なので
      '先にファイル先頭の日付を入れて置く
      dfn = FreeFile
      Open vntFileName For Input As dfn
      If Not EOF(dfn) Then
        'ファイルから1行読み込み
        Line Input #dfn, strBuff
        'フィールドに分割
        vntField = Split(strBuff, ",", , vbBinaryCompare)
      End If
      Close #dfn
      If VarType(vntField) = vbArray + vbVariant Then
        'ファイルから取得した日付書き込み
        .Offset(, 1).Value = vntField(0)
        lngCol = 1
      Else
        blnWayOut = True
        GoTo WayOut
      End If
    End If
    '日付列の範囲を取得
    Set rngDate = .Offset(, 1).Resize(, lngCol)
    'タグNo.が有る範囲を取得
    Set rngScope = Range(.Offset(2), .Offset(65536 - .Row).End(xlUp))
  End With
  
  '指定されたファイルをOpen
  dfn = FreeFile
  Open vntFileName For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
    'タグNo.を探索
    lngRow = GetTagNoRow(vntField(3), rngScope, rngResult)
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(4)
  Loop
  
  Close #dfn
  
WayOut:
  
  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing
  
  Application.ScreenUpdating = True

  Beep
  If blnWayOut Then
    MsgBox "ファイルが空です"
  Else
    MsgBox "処理が完了しました"
  End If
    
End Sub

Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngListTop As Range) As Long
  
  Dim lngFound As Long
  Dim lngOver As Long
  
  'セル値が数値として入力されている場合
  lngFound = DataSearch(CLng(vntDate), rngScope, lngOver)
  'セル値が文字列として入力されている場合
'  lngFound = DataSearch(vntDate, rngScope, lngOver)
  '日付が見つかった場合
  If lngFound > 0 Then
    '位置を返す
    GetDateColumn = lngFound
  Else
    With rngListTop
      '日付が最終列の以内の場合
      If lngOver <= rngScope.Columns.Count Then
        '指定位置に列を挿入
        .Offset(, lngOver).EntireColumn.Insert
      End If
      '日付を書き込み
      .Offset(, lngOver).Value = vntDate
      '挿入位置を返す
      GetDateColumn = lngOver
      '日付列の範囲を更新
      Set rngScope _
        = .Offset(, 1).Resize(, rngScope.Columns.Count + 1)
    End With
  End If
      
End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long
  
  Dim lngFound As Long
  Dim lngOver As Long
  
  lngFound = DataSearch(vntTagNo, rngScope, lngOver)
  If lngFound > 0 Then
    GetTagNoRow = lngFound + 1
  Else
    With rngListTop.Offset(1)
      If lngOver <= rngScope.Rows.Count Then
        .Offset(lngOver).EntireRow.Insert
      End If
      .Offset(lngOver).Value = vntTagNo
      GetTagNoRow = lngOver + 1
      Set rngScope _
        = .Offset(1).Resize(rngScope.Rows.Count + 1)
    End With
  End If

End Function

Private Function DataSearch(vntKey As Variant, _
            rngScope As Range, _
            Optional lngOver As Long) As Long

  Dim vntFind As Variant
  
  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, 1)
  lngOver = 1
  'もし、エラーで無いなら
  If Not IsError(vntFind) Then
    'もし、Key値と探索位置の値が等しいなら
    If vntKey = rngScope(vntFind).Value Then
      '戻り値として、行位置を代入
      DataSearch = vntFind
    End If
    'Key値を超える最小値のある行
    lngOver = vntFind + 1
  End If
  
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
1 hits

【20503】表へのCSVデータ挿入について ディノ 04/12/10(金) 15:31 質問
【20518】Re:表へのCSVデータ挿入について [名前なし] 04/12/10(金) 22:35 発言
【20519】Re:表へのCSVデータ挿入について ディノ 04/12/10(金) 22:54 質問
【20520】Re:表へのCSVデータ挿入について [名前なし] 04/12/10(金) 23:13 回答
【20521】Re:表へのCSVデータ挿入について ディノ 04/12/11(土) 0:39 質問
【20522】Re:表へのCSVデータ挿入について [名前なし] 04/12/11(土) 0:48 回答
【20523】Re:表へのCSVデータ挿入について [名前なし] 04/12/11(土) 1:24 発言
【20537】Re:表へのCSVデータ挿入について Hirofumi 04/12/11(土) 18:47 回答
【20603】Re:表へのCSVデータ挿入について Jaka 04/12/13(月) 10:51 回答
【20614】Re:表へのCSVデータ挿入について ディノ 04/12/13(月) 15:10 質問
【20640】Re:表へのCSVデータ挿入について Hirofumi 04/12/13(月) 19:46 回答
【20651】Re:表へのCSVデータ挿入について ディノ 04/12/14(火) 1:22 質問
【20675】Re:表へのCSVデータ挿入について Hirofumi 04/12/14(火) 19:33 回答
【20682】Re:表へのCSVデータ挿入について ディノ 04/12/15(水) 0:37 発言
【20699】Re:表へのCSVデータ挿入について Hirofumi 04/12/15(水) 21:17 回答
【20728】Re:表へのCSVデータ挿入について ディノ 04/12/16(木) 19:16 質問
【20730】Re:表へのCSVデータ挿入について Hirofumi 04/12/16(木) 20:14 回答
【20731】Re:表へのCSVデータ挿入について Hirofumi 04/12/16(木) 20:18 回答
【20735】Re:表へのCSVデータ挿入について ディノ 04/12/16(木) 22:05 質問
【20757】Re:表へのCSVデータ挿入について Hirofumi 04/12/17(金) 19:39 回答
【20759】Re:表へのCSVデータ挿入について ディノ 04/12/17(金) 20:53 質問
【20761】Re:表へのCSVデータ挿入について Hirofumi 04/12/17(金) 22:19 回答
【20763】Re:表へのCSVデータ挿入について Hirofumi 04/12/17(金) 23:04 回答
【20767】Re:表へのCSVデータ挿入について ディノ 04/12/18(土) 0:15 お礼

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