| |
指定期間内にログインしたユーザの取得を実施したい
指定した期間内にログインしたユーザの情報を取得したいと思っています。
以下の方針で取得する想定です。
使用ファイル：
master.csv ⇒ 全体のマスタ情報が格納されている
daily.csv ⇒ 直近60日程度の情報が格納されている
check.xlsm ⇒ VBAを設定するファイル
シート「master」「daily」「daily2」「daily3」「match」「BTN」がある
手順：
1.master.csvを読み込み、全体のマスタ情報を取得する
2.daily.csv情報を読み込み、直近のログイン情報を取得する
3.読み込んだdaily情報から、指定期間（2018/1/1〜2018/2/1）のレコード（アドレス）を抽出する
4.抽出した情報から、第4カラムが「FALSE」のもののみを抽出する
5.上記の4.で抽出した情報とmaster情報を紐付ける
想定では、test12@kkkk.onmicrosoft.comが出力されると思っていましたが、
何も抽出されませんでした。
どこが間違っていたのでしょうか？
お分かりになられる方、よろしくお願いいたします
コードは、以下のように作成しました
Option Explicit
Sub CSV_MATCH()
'指定期間内のログイン情報を抽出する
Dim hida As Long
Dim migi As Long
Dim cols1 As Long
Dim cols2 As String
Dim cols4 As String
Dim cols3 As Long
Dim stdate As String
Dim eddate As String
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim ws5 As Worksheet
Dim ws6 As Worksheet
Set ws1 = Worksheets("master")
Set ws2 = Worksheets("daily")
Set ws3 = Worksheets("match")
Set ws4 = Worksheets("BTN")
Set ws5 = Worksheets("daily2")
Set ws6 = Worksheets("daily3")
With Sheets("master")
cols1 = .UsedRange.Cells(.UsedRange.Rows.Count, 1).Column
End With
' With Sheets("daily")
' cols2 = .UsedRange.Cells(.UsedRange.Rows.Count,1).Column
' End With
'日付範囲を指定した日次情報の貼り付け先(daily2)を空白にする
ws5.Cells.Clear
ws6.Cells.Clear
ws2.Activate
ActiveSheet.AutoFilterMode = False
'抽出する日次情報の範囲を指定する
stdate = InputBox("ﾃﾞｰﾀ抽出開始日を入力してください。（2018/1/1形式で入力）")
eddate = InputBox("ﾃﾞｰﾀ抽出終了日を入力してください。（2018/1/1形式で入力）")
'日付範囲を指定した日次情報をdaily2へ貼り付ける
Range("A1").AutoFilter Field:=1, Criteria1:=">=" & stdate, Operator:=xlAnd, Criteria2:="<=" & eddate
ws2.Range("A1").CurrentRegion.Copy ws5.Range("A1")
ws2.AutoFilterMode = False
'ログイン情報の貼り付け先（match）を空白にする
ws3.Cells.Clear
ws5.Activate
Dim i, LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 4) = False Then
Rows(i).Copy Sheets("daily3").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next i
With Sheets("daily3")
cols3 = .UsedRange.Cells(.UsedRange.Rows.Count, 1).Column
End With
'日付情報のメールアドレスとマスタ情報のメールアドレスが一致したレコードを、matchに貼り付ける
For migi = 1 To cols1
Application.StatusBar = "処理実行中．．．．(現在 " & migi & "件)"
For hida = 1 To cols3
If ws6.Range("B" & migi).Value = ws1.Range("D" & hida).Value Then
ws3.Range("A" & hida).Value = ws1.Range("B" & hida).Value
ws3.Range("B" & hida).Value = ws1.Range("D" & hida).Value
ws3.Range("C" & hida).Value = ws1.Range("C" & hida).Value
ws3.Range("D" & hida).Value = ws1.Range("A" & hida).Value
Exit For
End If
Next
ws3.Range("H" & hida).Value = migi
ws3.Range("I" & hida).Value = hida
Next
Application.StatusBar = "処理完了．．．．(全 " & migi - 1 & "件)"
'抽出した情報を部署単位で並び替える
ws3.Activate
ws3.Range("A:K").Sort Key1:=Range("D1"), order1:=xlAscending
'初期画面に戻る
ws4.Activate
End Sub
daily.csv
Date,Name,Display, Deleted
2018/2/7,test3@kkkk.onmicrosoft.com,テスト 3,FALSE
2018/2/7,test4@kkkk.onmicrosoft.com,テスト 4,FALSE
2018/2/7,test5@kkkk.onmicrosoft.com,テスト 5,FALSE
2018/2/7,test6@kkkk.onmicrosoft.com,テスト 6,FALSE
2018/2/7,test7@kkkk.onmicrosoft.com,テスト 7,FALSE
2018/2/7,test8@kkkk.onmicrosoft.com,テスト 8,FALSE
2018/2/7,test9@kkkk.onmicrosoft.com,テスト 9,FALSE
2018/2/7,test10@kkkk.onmicrosoft.com,テスト 10,FALSE
2018/1/9,test11@kkkk.onmicrosoft.com,テスト 11,TRUE
2018/1/9,test12@kkkk.onmicrosoft.com,テスト 12,FALSE
master.csv
COL1,COL2,COL3,mail,COL4
Mod,TMTM43045,KM4,ssstest3@kkkk.onmicrosoft.com,1043045
Mod,aaTMTM43046,KM5,tsssest3@kkkk.onmicrosoft.com,1043046
Mod,aaTMTM43047,KM6,ssstest3@kkkk.onmicrosoft.com,1043047
Mod,aaTMTM43048,KM7,ssstest3@kkkk.onmicrosoft.com,1043048
Mod,aaTMTM43049,KM8,ssstest3@kkkk.onmicrosoft.com,1043049
Mod,aaTMTM43050,KM4,test3@kkkk.onmicrosoft.com,1043050
Mod,aaTMTM43056,KM4,test9@kkkk.onmicrosoft.com,1043056
Mod,aaTMTM43045,KM4,test10@kkkk.onmicrosoft.com,1043045
Mod,aaTMTM43046,KM5,test11@kkkk.onmicrosoft.com,1043046
Mod,aaTMTM43047,KM6,test12@kkkk.onmicrosoft.com,1043047
Mod,aaTMTM43048,KM7,test13@kkkk.onmicrosoft.com,1043048
|
|
amatsuno
- 18/2/14(水) 16:19 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
≪
