Excel VBA質問箱 IV

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

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


54260 / 76732 ←次へ | 前へ→

【27268】Re:日付列を取得し、CSVデータを挿入について
回答  Hirofumi  - 05/8/3(水) 23:10 -

引用なし
パスワード
   結構、あっちこっち直さないと使え無い見たい?

Option Explicit

Public Sub 商品()

  '日付の先頭位置(A列からのOffset値)
  Const clngTop As Long = 3
  
  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

  '「ファイルを開く」ダイアログを表示
Dim fileToOpen As Variant

'ChDrive ""
'ChDir ""
fileToOpen = Application.GetOpenFilename("テキスト ファイル (*.txt), *.txt")


  Application.ScreenUpdating = False

  'ActiveSheetのA1セルを基準とする(Listの左上隅)
  Set rngResult = ActiveSheet.Cells(1, "A") '◎要変更?
  With rngResult
    '日付の書かれている列数を取得
    lngCol = .Offset(, 256 - .Column).End(xlToLeft).Column _
          - .Offset(, clngTop).Column + 1 '◎要変更?
    '日付の有る範囲を取得
     If lngCol = 0 Then
      blnWayOut = True
      GoTo WayOut
    End If
    '日付列の範囲を取得
    Set rngDate = .Offset(, clngTop).Resize(, lngCol) '◎要変更?
    'No.が有る範囲を取得
    Set rngScope = Range(.Offset(1), .Offset(65536 - .Row).End(xlUp))
  End With


  '指定されたファイルをOpen
  dfn = FreeFile
  Open fileToOpen For Input As dfn

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '日付を探索
    vntField(0) = DateValue(Left(vntField(0), 4) & _
                "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)) '★この行追加
    lngCol = GetDateColumn(vntField(0), rngDate, rngResult)
    'No.を探索
    lngRow = GetTagNoRow(vntField(1), rngScope, rngResult) '◎要変更?
    '日付、TagNoの交差するセルに値を書き込み
    rngResult.Offset(lngRow, lngCol).Value = vntField(2) '◎要変更?
  Loop

  Close #dfn

WayOut:

  Set rngScope = Nothing
  Set rngDate = Nothing
  Set rngResult = Nothing

  Application.ScreenUpdating = True
 
End Sub

Private Function GetDateColumn(vntDate As Variant, _
                rngScope As Range, _
                rngListTop As Range) As Long

  '日付の先頭位置(A列からのOffset値)
  Const clngTop As Long = 3
  
  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 + clngTop - 1
  Else
    With rngListTop
      '日付が最終列の以内の場合
      If lngOver <= rngScope.Columns.Count Then
        '指定位置に列を挿入
        .Offset(, lngOver + clngTop - 1).EntireColumn.Insert
      End If
      '日付を書き込み
      .Offset(, lngOver + clngTop - 1).Value = vntDate
      '挿入位置を返す
      GetDateColumn = lngOver + clngTop - 1
      '日付列の範囲を更新
      Set rngScope _
        = .Offset(, clngTop).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
  Else
    With rngListTop.Offset(1)
      If lngOver <= rngScope.Rows.Count Then
        .Offset(lngOver).EntireRow.Insert
      End If
      .Offset(lngOver).Value = vntTagNo
      GetTagNoRow = lngOver
      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
2 hits

【27171】日付列を取得し、CSVデータを挿入について mimi 05/8/1(月) 1:28 質問
【27174】Re:日付列を取得し、CSVデータを挿入につ... だるま 05/8/1(月) 8:16 回答
【27178】Re:日付列を取得し、CSVデータを挿入につ... mimi 05/8/1(月) 10:15 発言
【27193】Re:日付列を取得し、CSVデータを挿入につ... だるま 05/8/1(月) 15:03 発言
【27196】Re:日付列を取得し、CSVデータを挿入につ... だるま 05/8/1(月) 15:23 回答
【27182】CSVデータの構造について m2m10 05/8/1(月) 11:34 お礼
【27187】Re:CSVデータの構造について mimi 05/8/1(月) 12:49 発言
【27195】Re:日付列を取得し、CSVデータを挿入につい... m2m10 05/8/1(月) 15:21 回答
【27205】Re:日付列を取得し、CSVデータを挿入につい... m2m10 05/8/1(月) 17:35 回答
【27209】Re:日付列を取得し、CSVデータを挿入につい... mimi 05/8/1(月) 22:12 質問
【27214】日付を探索 をする際に m2m10 05/8/2(火) 7:57 回答
【27264】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/3(水) 21:11 回答
【27266】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/3(水) 21:46 回答
【27268】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/3(水) 23:10 回答
【27307】Re:日付列を取得し、CSVデータを挿入につい... mimi 05/8/4(木) 19:30 質問
【27308】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/4(木) 20:10 回答
【27309】Re:日付列を取得し、CSVデータを挿入につい... Hirofumi 05/8/4(木) 20:13 回答
【27310】コードを整理して見ました Hirofumi 05/8/4(木) 21:40 回答
【27341】Re:コードを整理して見ました mimi 05/8/5(金) 19:57 質問
【27346】Re:コードを整理して見ました Hirofumi 05/8/5(金) 22:36 回答
【27348】Re:コードを整理して見ました mimi 05/8/5(金) 23:17 質問
【27349】Re:コードを整理して見ました Hirofumi 05/8/5(金) 23:57 回答
【27351】Re:コードを整理して見ました mimi 05/8/6(土) 1:29 お礼
【27352】Re:コードを整理して見ました Hirofumi 05/8/6(土) 5:59 発言
【27353】書き忘れた事がもう1点有りました Hirofumi 05/8/6(土) 7:40 発言
【27354】Re:書き忘れた事がもう1点有りました mimi 05/8/6(土) 12:37 質問
【27369】変更したコード Hirofumi 05/8/6(土) 16:35 回答
【27370】Re:変更したコード mimi 05/8/6(土) 19:02 お礼

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