Excel VBA質問箱 IV

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

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


58086 / 76732 ←次へ | 前へ→

【23378】Re:顧客データから、最新の顧客情報のみ取り...
回答  Hirofumi  - 05/3/20(日) 10:53 -

引用なし
パスワード
   必ずデータのバックアップを取ってから実行して下さい
データListの有るシートをアクティブシートとします
データListの1行目は、列見出しが有る物とします

Option Explicit

Public Sub Redundancy()

  Dim i As Long
  Dim lngRows As Long
  Dim lngColumns As Long
  Dim lngPos As Long
  Dim vntData As Variant
  Dim vntKeys As Variant
  Dim dicIndex As Object
  Dim rngList As Range
  Dim strProm As String
  
  'データListの左上隅(「ID」の列見出し位置)のセル位置を基準とする
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'List行数を取得
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    'List列数を取得
    lngColumns = .Offset(, 256 - .Column).End(xlToLeft).Column - .Column + 1
    If lngRows < 2 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    '「ID」列を配列に取得
    vntData = .Resize(lngRows).Value
    '「来店日」列を配列に取得
    vntKeys = .Offset(, 2).Resize(lngRows).Value
  End With
  
  'Dictionaryオブジェクトのインスタンスを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  With dicIndex
    'データListの2行目(1行目は列見出しなので)から全てに繰り返し
    For i = 2 To UBound(vntData, 1)
      'DictionaryにIDの登録が有る場合
      If .Exists(vntData(i, 1)) Then
        '登録されたIDの行位置を取得
        lngPos = .Item(vntData(i, 1))
        '登録された位置の日付より現在の日付が後の場合
        If vntKeys(lngPos, 1) < vntKeys(i, 1) Then
          '現在のIDの位置に登録更新
          .Item(vntData(i, 1)) = i
        End If
      Else
        'IDと行位置を登録
        .Add vntData(i, 1), i
      End If
      'ID配列の現在位置をクリア
      vntData(i, 1) = Empty
    Next i
    '登録数を取得
    lngPos = .Count
    '登録されたKeyを全て取得
    vntKeys = .Keys
    '登録されたKeyを全てに繰り返し
    For i = 0 To lngPos - 1
      '残す行位置に"*"を書き込み
      vntData(.Item(vntKeys(i)), 1) = "*"
    Next i
  End With
  
  'Dictionaryオブジェクトのインスタンスを破棄
  Set dicIndex = Nothing
  
  Application.ScreenUpdating = False
  
  '出力
  With rngList
    '残す行の印を最終列の後ろに出力
    .Offset(, lngColumns).Resize(lngRows).Value = vntData
    '残す行の印をKeyにて整列
    With .Resize(lngRows, lngColumns + 1)
      .Sort Key1:=.Item(1, lngColumns + 1), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        SortMethod:=xlStroke
    End With
    '削除する先頭行位置取得(行Offset)
    lngPos = lngPos + 1
    '削除する最終行位置取得(行Offset)
    lngRows = lngRows - 1
    '削除する行が有るなら
    If lngPos <= lngRows Then
      '行を削除
      .Offset(lngPos).Resize(lngRows - lngPos + 1).EntireRow.Delete
    End If
    ''残す行の印の有る列を削除
    .Offset(, lngColumns).EntireColumn.Delete
  End With
  
  Application.ScreenUpdating = True
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Set rngList = Nothing
  
  Beep
  MsgBox strProm
  
End Sub
0 hits

【23375】顧客データから、最新の顧客情報のみ取り... SI 05/3/20(日) 2:57 質問
【23376】Re:顧客データから、最新の顧客情報のみ取... ちゃっぴ 05/3/20(日) 3:10 回答
【23378】Re:顧客データから、最新の顧客情報のみ取... Hirofumi 05/3/20(日) 10:53 回答
【23383】Re:顧客データから、最新の顧客情報のみ取... SI 05/3/20(日) 13:47 お礼

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