Excel VBA質問箱 IV

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

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


54163 / 76732 ←次へ | 前へ→

【27369】変更したコード
回答  Hirofumi  - 05/8/6(土) 16:35 -

引用なし
パスワード
   >あと2点ほど質問があるのですが
>・日付が無い場合、自動入力されますがこれを止めてmsgbox"日付が見つかりません"にするには
>何処を変える必要があるでしょうか
>
>・商品名が無い場合、昇順で行が追加されます。これを止めて最終行に追加するには
>どのようにすれば良いでしょうか?

Option Explicit

Public Sub 商品1()

  '日付の先頭位置の前の列(「数量」の見だし位置のA列からのOffset値)
  Const clngTop As Long = 2

  Dim strPath As String
  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 strProm As String
  Dim strNoMatch As String

  'Textファイルの有るフォルダを指定
  strPath = "C:\Program Files\KEYENCE\BT-500\DATA"

  '「ファイルを開く」ダイアログを表示
  If Not GetReadFile(vntFileName, strPath, False) Then
    strProm = "マクロがキャンセルされました"
    GoTo WayOut
  End If

  Application.ScreenUpdating = False

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

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

  'ファイルから日付を取得
  Do Until EOF(dfn)
    'ファイルから1行読み込み
    Line Input #dfn, strBuff
    'フィールドに分割
    vntField = Split(strBuff, ",", , vbBinaryCompare)
    '「20050731」形式の日付をシリアル値に変換
    vntField(0) = CLng(DateValue(Left(vntField(0), 4) _
                & "/" & Mid(vntField(0), 5, 2) _
                & "/" & Right(vntField(0), 2)))
    '日付を探索
    lngCol = GetDateColumn(vntField(0), rngDate, _
                rngResult.Offset(, clngTop)) + clngTop
    If lngCol = 0 + clngTop Then
      '該当日付が無い場合、メセージを出して継続する場合
'      With Application
'        If Not .ScreenUpdating Then
'          .ScreenUpdating = True
'        End If
'      End With
'      MsgBox Format(vntField(0), "m/d") & " の該当日付が有りません", _
'                    vbOKOnly + vbInformation, "NoMatch"
'      If strNoMatch <> "" Then
'        strNoMatch = strNoMatch & vbCrLf
'      End If
'      strNoMatch = strNoMatch & Format(vntField(0), "m/d") & " " & vntField(5)
      '該当日付が無い場合、メセージを出し直ちに終了する場合
      strProm = Format(vntField(0), "m/d") & " の日付が該当しませんので終了します"
      GoTo WayOut
    Else
      'No.を探索
      lngRow = GetTagNoRow(vntField(5), rngScope, rngResult) 'vntField(5)でOK
      '日付、TagNoの交差するセルに値を書き込み
      With rngResult.Offset(lngRow, lngCol)
        .NumberFormatLocal = "G/標準"
        .Value = vntField(6)    'vntField(6)でOK
      End With
    End If
  Loop

  If strNoMatch = "" Then
    strProm = "処理が完了しました"
  Else
    strProm = "以下の該当しない日付がファイルに存在します" & vbCrLf & strNoMatch
  End If
    
WayOut:

  Close #dfn
  
  Application.ScreenUpdating = True

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

  Beep
  MsgBox strProm

End Sub

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

  Dim lngFound As Long

  '日付範囲に日付が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
  Else
    '日付の探索
    'セル値が数値として入力されている場合
    lngFound = DataSearch(CLng(vntDate), rngScope)
    'セル値が文字列として入力されている場合
'    lngFound = DateSearch(vntDate, rngScope)
  End If

  GetDateColumn = lngFound

End Function

Private Function GetTagNoRow(vntTagNo As Variant, _
            rngScope As Range, _
            rngListTop As Range) As Long

  Dim lngFound As Long
  Dim lngCount As Long

  '商品名範囲に商品名が無いなら
  If rngScope Is Nothing Then
    lngFound = 0
    lngCount = 0
  Else
    '商品名を探索
    lngFound = DataSearch(vntTagNo, rngScope, , 0)
    lngCount = rngScope.Rows.Count
  End If

  '探索成功(商品名が有るなら)
  If lngFound > 0 Then
    '位置を返す
    GetTagNoRow = lngFound
  Else
    With rngListTop
      '行末位置を更新
      lngCount = lngCount + 1
      '行末に商品名を書き込み
      .Offset(lngCount).Value = vntTagNo
      '挿入位置を返す
      GetTagNoRow = lngCount
      '探索範囲の更新
      Set rngScope _
        = .Offset(1).Resize(lngCount)
    End With
  End If

End Function

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

  Dim vntFind As Variant

  'Matchによる二分探索
  vntFind = Application.Match(vntKey, rngScope, lngMode)
  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, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If

  GetReadFile = True

End Function

1 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 お礼

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