Excel VBA質問箱 IV

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

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


10162 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【23375】顧客データから、最新の顧客情報のみ取り...
質問  SI  - 05/3/20(日) 2:57 -

引用なし
パスワード
   いつもお世話になります。
顧客データで悪戦苦闘しています。

A(ID) B(名前) C(来店日) D(感想)

100 田中 2005/01/10 良い
101 鈴木 2005/01/10 普通
102 佐藤 2005/01/20 悪い
103 新井 2005/01/20 普通
100 田中 2005/01/30 普通
104 三浦 2005/02/10 普通
103 新井 2005/02/10 良い

という表を、
(ここでは、田中さんと新井さんがだぶって
います)

100 田中 2005/01/30 普通
101 鈴木 2005/01/10 良い
102 佐藤 2005/01/20 悪い
103 新井 2005/02/10 普通
104 三浦 2005/02/10 普通

というように、

重複する人の一番最新のデータのみを残した表に、
エクセルでなんとかできないかと考えていますが、
なかなか思い通りに行きません。

ちなみに、実際は10,000件ほどあり、実数の人の数は、
2000〜3000件ほどだと思います。
重複の一番多い人は、10回を超えています。

申し訳ないのですが、アドバイスをお願いします。

【23376】Re:顧客データから、最新の顧客情報のみ...
回答  ちゃっぴ  - 05/3/20(日) 3:10 -

引用なし
パスワード
   顧客DataをExcelで管理しているようですが、
情報漏洩対策は大丈夫ですかね?

4月から個人情報保護法が施行され、5000件以上の個人情報を
所持している事業者は、適応されますよ。

DBできちんとしたSecurity対策を行うことをお勧めします。

個人情報保護法対策に関しては、ここでお勉強ください。

ITmediaニュース:個人情報保護特集
http://www.itmedia.co.jp/news/privacy/


なお本題ですが、Sortしてみれば考え方が整理しやすいでしょう。
あと、AdvanceFilterを使用してやる方法もありますね。

ただし、同姓同名の扱いをどうするかなどの問題はどうするのでしょうかね?

【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

【23383】Re:顧客データから、最新の顧客情報のみ...
お礼  SI  - 05/3/20(日) 13:47 -

引用なし
パスワード
   早速の回答ありがとうございます!

ちゃっぴさんへ

 個人情報保護法は、そうですね。3000件と言えども、
 注意していきたいと思います。

Hirofumiさんへ

 詳細な内容ありがとうございます。
 試してみます!!

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