Excel VBA質問箱 IV

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

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


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

【20493】重複データの整理について m3 04/12/10(金) 13:58 質問[未読]
【20517】Re:重複データの整理について [名前なし] 04/12/10(金) 22:11 回答[未読]
【20542】Re:重複データの整理について m3 04/12/11(土) 20:36 質問[未読]
【20545】Re:重複データの整理について [名前なし] 04/12/11(土) 21:20 発言[未読]
【20548】Re:重複データの整理について m3 04/12/11(土) 22:39 質問[未読]
【20550】Re:重複データの整理について [名前なし] 04/12/11(土) 23:01 発言[未読]
【20552】Re:重複データの整理について m3 04/12/11(土) 23:08 質問[未読]
【20554】Re:重複データの整理について m3 04/12/11(土) 23:34 発言[未読]
【20555】Re:重複データの整理について [名前なし] 04/12/11(土) 23:40 回答[未読]
【20556】Re:重複データの整理について m3 04/12/12(日) 0:46 お礼[未読]
【20567】Re:重複データの整理について m3 04/12/12(日) 12:02 質問[未読]
【20569】Re:重複データの整理について [名前なし] 04/12/12(日) 12:46 回答[未読]
【20570】Re:重複データの整理について m3 04/12/12(日) 14:46 お礼[未読]
【20571】Re:重複データの整理について [名前なし] 04/12/12(日) 14:52 発言[未読]
【20584】Re:重複データの整理について m3 04/12/12(日) 22:02 質問[未読]
【20585】Re:重複データの整理について [名前なし] 04/12/12(日) 23:10 回答[未読]
【20589】Re:重複データの整理について m3 04/12/13(月) 0:23 質問[未読]
【20592】Re:重複データの整理について [名前なし] 04/12/13(月) 1:02 回答[未読]
【20593】Re:重複データの整理について m3 04/12/13(月) 1:16 お礼[未読]
【20598】Re:重複データの整理について Jaka 04/12/13(月) 9:11 回答[未読]

【20493】重複データの整理について
質問  m3  - 04/12/10(金) 13:58 -

引用なし
パスワード
   下記は勤怠管理のテキストデータになります。
左から日付,時間,種別(1:出勤、2:退勤),個人IDです。
20041207,0800,1,12011013
20041207,0802,1,12011005
20041207,0802,1,12011007
20041207,0805,1,12011010
20041207,0808,1,12013001
20041207,0813,1,12013003
20041207,1733,2,12011010
20041207,1734,2,12011013
20041207,1734,2,12011005
20041207,1734,2,12011007
20041207,1734,2,12013003
20041207,1735,2,12013001

これを
日付,個人ID,出勤時間,退勤時間へと編集したく思います。
(例:20041207 12011013 08:00 17:34)

下記内容で退勤時間のセルの移動までできました。
この後、どの様に組めばよいでしょうか?

Sub 勤怠2()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application    ' Applicationオブジェクト
  Dim intFF As Integer      ' FreeFile値
  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
  Dim GYO As Long         ' 収容するセルの行
  Dim lngREC As Long       ' レコード件数カウンタ
  
  Set xlAPP = Application
  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
  
  intFF = FreeFile
  Open strFILENAME For Input As #intFF
  GYO = 1
  Do Until EOF(intFF)
    lngREC = lngREC + 1
    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
    Input #intFF, X(1), X(2), X(3), X(4)
    GYO = GYO + 1
  
  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
  If X(3) = 1 Then
    Cells(GYO, 3) = X(2)     '第2項目をB3セルへ
    Else
    Cells(GYO, 4) = X(2)     '第2項目をB4セルへ
    End If
  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ
   
  Loop
  ' 指定ファイルをCLOSE
  Close #intFF
  xlAPP.StatusBar = False
  ' 終了の表示
  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
End Sub

【20517】Re:重複データの整理について
回答  [名前なし]  - 04/12/10(金) 22:11 -

引用なし
パスワード
   >Sub 勤怠2()
>  Const cnsTITLE = "テキストファイル読み込み処理"
>  Const cnsFILTER = "全てのファイル (*.*),*.*"
>  Dim xlAPP As Application    ' Applicationオブジェクト
>  Dim intFF As Integer      ' FreeFile値
>  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
>  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
>  Dim GYO As Long         ' 収容するセルの行
>  Dim lngREC As Long       ' レコード件数カウンタ
>  
>  Set xlAPP = Application
>  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
>  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
>    Title:=cnsTITLE)
>  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
>  
>  intFF = FreeFile
>  Open strFILENAME For Input As #intFF
>  GYO = 1
>  Do Until EOF(intFF)
>    lngREC = lngREC + 1
>    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
>    Input #intFF, X(1), X(2), X(3), X(4)
>    GYO = GYO + 1
>  
>  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
   Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
>  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ
>   
>  Loop
>  ' 指定ファイルをCLOSE
>  Close #intFF
>  xlAPP.StatusBar = False
>  ' 終了の表示
  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
>  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
>    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
  Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Header:=xlGuess
  Range("D2").Delete Shift:=xlUp
  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Cells(lngCnt, 1).Activate
    If ActiveCell.Offset(0, 2).Value = "" Then
      ActiveCell.EntireRow.Delete Shift:=xlUp
    End If
  Next
>End Sub

でどうでしょうか。

【20542】Re:重複データの整理について
質問  m3  - 04/12/11(土) 20:36 -

引用なし
パスワード
   アドバイスありがとうございます。
いろいろ試してみました。

そこで2点質問があります。
1、
CSVは下記のように
日付、時間、種別(1:出勤、2:退勤)、個人IDです。
20041201,0806,1,11013015
20041201,1730,2,11013015
これが並び替えで
20041201,11013015,0806,1730
になります。

しかし、出勤時間が存在せず、退勤時間のみある場合
20041201,0806,1,11013015
20041201,1730,2,11013015
20041201,1730,2,11013016
並び替え後
20041201,11013015,0806,1730 になります。
ID:11013016の退勤時間は消滅してしまいます。
これが理解できません。
何故でしょうか?

2、
日付順に並べようと思い
並び替えのところを Key1:=Range("A1") にしました。
そうするとD列:退勤時間が同じ日付に対し1件しか表示しなくなります。
何故でしょうか?


Sub 勤怠2()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application    ' Applicationオブジェクト
  Dim intFF As Integer      ' FreeFile値
  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
  Dim GYO As Long         ' 収容するセルの行
  Dim lngREC As Long       ' レコード件数カウンタ

  Set xlAPP = Application
  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

  intFF = FreeFile
  Open strFILENAME For Input As #intFF
  GYO = 1
  Do Until EOF(intFF)
    lngREC = lngREC + 1
    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
    Input #intFF, X(1), X(2), X(3), X(4)
    GYO = GYO + 1

  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
   Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ

  Loop
  ' 指定ファイルをCLOSE
  Close #intFF
  xlAPP.StatusBar = False
  ' 終了の表示
  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
-> Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Header:=xlGuess
  Range("D2").Delete Shift:=xlUp
  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Cells(lngCnt, 1).Activate
    If ActiveCell.Offset(0, 2).Value = "" Then
      ActiveCell.EntireRow.Delete Shift:=xlUp
    End If
  Next
End Sub

【20545】Re:重複データの整理について
発言  [名前なし]  - 04/12/11(土) 21:20 -

引用なし
パスワード
   >並び替え後
>20041201,11013015,0806,1730 になります。
>ID:11013016の退勤時間は消滅してしまいます。
>これが理解できません。
>何故でしょうか?
サンプルデータからみて、出勤時間と退勤時間は必ず対になっていると思っていました。
結果、Range("D2").Delete Shift:=xlUp実行時点で、データは
20041201,11013015,0806,1730
20041201,11013015
になるはずです。そのため、下から5行目の
If ActiveCell.Offset(0, 2).Value = "" Then
で、出勤時間が空白の時その行を削除しています。
退勤時間のみだけでなく、出勤時間のみというのもありえるのであれば、
If ActiveCell.Offset(0, 2).Value = "" And ActiveCell.Offset(0, 3).Value = "" Then
にしないといけません。それ以前に、
20041201,11013015,0806,
20041201,11013015,  ,1730
20041201,11013016,  ,1730
となっていた場合、Range("D2").Delete Shift:=xlUpで
20041201,11013015,0806,1730
20041201,11013015,  ,1730
20041201,11013016,  ,
になってしまうため、コードを見直す必要があります。
>2、
>日付順に並べようと思い
>並び替えのところを Key1:=Range("A1") にしました。
>そうするとD列:退勤時間が同じ日付に対し1件しか表示しなくなります。
>何故でしょうか?
その状態が再現できるサンプルデータを教えていただけませんか?

【20548】Re:重複データの整理について
質問  m3  - 04/12/11(土) 22:39 -

引用なし
パスワード
   ご返事ありがとうございます。

>>2、
>>日付順に並べようと思い
>>並び替えのところを Key1:=Range("A1") にしました。
>>そうするとD列:退勤時間が同じ日付に対し1件しか表示しなくなります。
>>何故でしょうか?
>その状態が再現できるサンプルデータを教えていただけませんか?


下記がサンプルデータになります。
アドバイスをお願いいたします。


Sub 勤怠2()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application    ' Applicationオブジェクト
  Dim intFF As Integer      ' FreeFile値
  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
  Dim GYO As Long         ' 収容するセルの行
  Dim lngREC As Long       ' レコード件数カウンタ

  Set xlAPP = Application
  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

  intFF = FreeFile
  Open strFILENAME For Input As #intFF
  GYO = 1
  Do Until EOF(intFF)
    lngREC = lngREC + 1
    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
    Input #intFF, X(1), X(2), X(3), X(4)
    GYO = GYO + 1

  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
   Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ

  Loop
  ' 指定ファイルをCLOSE
  Close #intFF
  xlAPP.StatusBar = False
  ' 終了の表示
  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlGuess
  Range("D2").Delete Shift:=xlUp
  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Cells(lngCnt, 1).Activate
    If ActiveCell.Offset(0, 2).Value = "" Then
      ActiveCell.EntireRow.Delete Shift:=xlUp
    End If
  Next
End Sub

【20550】Re:重複データの整理について
発言  [名前なし]  - 04/12/11(土) 23:01 -

引用なし
パスワード
   すみません。サンプルデータは、最初の質問にあった下のようなデータのことです。
最初の質問にあったデータですと、
>そうするとD列:退勤時間が同じ日付に対し1件しか表示しなくなります。
>何故でしょうか?
が再現できないようなんですが・・・。
これが再現できるようなデータの並びを教えて欲しかったのです。

20041207,0800,1,12011013
20041207,0802,1,12011005
20041207,0802,1,12011007
20041207,0805,1,12011010
20041207,0808,1,12013001
20041207,0813,1,12013003
20041207,1733,2,12011010
20041207,1734,2,12011013
20041207,1734,2,12011005
20041207,1734,2,12011007
20041207,1734,2,12013003
20041207,1735,2,12013001

【20552】Re:重複データの整理について
質問  m3  - 04/12/11(土) 23:08 -

引用なし
パスワード
   申し訳ありませんでした。

20041201,0801,1,11013005
20041201,0804,1,11013025
20041201,0806,1,11013039
20041201,0806,1,11013016
20041201,1730,2,11013005
20041201,1803,2,11013025
20041201,1903,2,11013039
20041202,0802,1,11013001
20041202,0830,1,11013008
20041202,0830,1,11013005
20041202,1600,2,11013005
20041202,1601,2,11013006
20041202,1950,2,11013001
20041202,1923,2,11013008

【20554】Re:重複データの整理について
発言  m3  - 04/12/11(土) 23:34 -

引用なし
パスワード
   >>2、
>>日付順に並べようと思い
>>並び替えのところを Key1:=Range("A1") にしました。
>>そうするとD列:退勤時間が同じ日付に対し1件しか表示しなくなります。
>>何故でしょうか?
>その状態が再現できるサンプルデータを教えていただけませんか?

申し訳ありません。
上記、2の質問、
下記内容で解決しました。

先の1の質問については現在工夫中です。


Sub 勤怠2()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application    ' Applicationオブジェクト
  Dim intFF As Integer      ' FreeFile値
  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
  Dim GYO As Long         ' 収容するセルの行
  Dim lngREC As Long       ' レコード件数カウンタ

  Set xlAPP = Application
  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

  intFF = FreeFile
  Open strFILENAME For Input As #intFF
  GYO = 1
  Do Until EOF(intFF)
    lngREC = lngREC + 1
    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
    Input #intFF, X(1), X(2), X(3), X(4)
    GYO = GYO + 1

  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
   Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ

  Loop
  ' 指定ファイルをCLOSE
  Close #intFF
  xlAPP.StatusBar = False
  ' 終了の表示
  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
  Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Header:=xlGuess
  Range("D2").Delete Shift:=xlUp
  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Cells(lngCnt, 1).Activate
    If ActiveCell.Offset(0, 2).Value = "" Then
      ActiveCell.EntireRow.Delete Shift:=xlUp
    End If
  Next
  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlGuess
 
  
End Sub

【20555】Re:重複データの整理について
回答  [名前なし]  - 04/12/11(土) 23:40 -

引用なし
パスワード
   下記の点を変更してみてください。

>Sub 勤怠2()
>  Const cnsTITLE = "テキストファイル読み込み処理"
>  Const cnsFILTER = "全てのファイル (*.*),*.*"
>  Dim xlAPP As Application    ' Applicationオブジェクト
>  Dim intFF As Integer      ' FreeFile値
>  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
>  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
>  Dim GYO As Long         ' 収容するセルの行
>  Dim lngREC As Long       ' レコード件数カウンタ
>
>  Set xlAPP = Application
>  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
>  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
>    Title:=cnsTITLE)
>  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
>
>  intFF = FreeFile
>  Open strFILENAME For Input As #intFF
>  GYO = 1
>  Do Until EOF(intFF)
>    lngREC = lngREC + 1
>    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
>    Input #intFF, X(1), X(2), X(3), X(4)
>    GYO = GYO + 1
>
>  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
>   Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
>  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ
>
>  Loop
>  ' 指定ファイルをCLOSE
>  Close #intFF
>  xlAPP.StatusBar = False
>  ' 終了の表示
>  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
>  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
>    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
>  Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Header:=xlGuess
  ' Range("D2").Delete Shift:=xlUp ←この行は不要
>  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Cells(lngCnt, 4).Activate 'D列を参照する
    'D列が空白で、日付・個人IDが下の行と同じなら
    If ActiveCell.Value = "" And _
    ActiveCell.Offset(0, -3).Value = ActiveCell.Offset(1, -3).Value And _
    ActiveCell.Offset(0, -2).Value = ActiveCell.Offset(1, -2).Value Then
      ActiveCell.Value = ActiveCell.Offset(1, 0).Text '下の退勤時間を書き込む
      ActiveCell.Offset(1, 0).EntireRow.Delete Shift:=xlUp '1行下を削除
    End If
>  Next
>  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlGuess
> 
>  
>End Sub

【20556】Re:重複データの整理について
お礼  m3  - 04/12/12(日) 0:46 -

引用なし
パスワード
   すばらしい回答ありがとう御座いました。
本当に感謝いたします。

まだまだVBAを学び、回答のお手伝いが出来る様
努力していきたく思います。

【20567】Re:重複データの整理について
質問  m3  - 04/12/12(日) 12:02 -

引用なし
パスワード
   最後に一つだけ質問させてください。
テキストファイルから("日付", "個人ID", "出勤時間", "退勤時間")を
毎日取り込む場合、新しいデータを
例えばA1を起点に挿入し、ダウンシフトするものと思います。
恐らく Range("A2").Insert Shift:=xlDown になると思います。
マクロのどの部分で設定すればよいでしょうか?
なかなか上手くいきません。

また、誤って同じデータを挿入した場合を考え
重複データの削除設定も行いたいのですが、
これは、1行下のデータが同じ場合、1行下を削除する。
を最後に指定すればよいでしょうか?

Sub 勤怠3()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application    ' Applicationオブジェクト
  Dim intFF As Integer      ' FreeFile値
  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
  Dim GYO As Long         ' 収容するセルの行
  Dim lngREC As Long       ' レコード件数カウンタ

  Set xlAPP = Application
  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

  intFF = FreeFile
  Open strFILENAME For Input As #intFF
  GYO = 1
  Do Until EOF(intFF)
    lngREC = lngREC + 1
    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
    Input #intFF, X(1), X(2), X(3), X(4)
    GYO = GYO + 1

  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
  Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ

  Loop
  ' 指定ファイルをCLOSE
  Close #intFF
  xlAPP.StatusBar = False
  ' 終了の表示
  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
  Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Header:=xlGuess

  ' Range("D2").Delete Shift:=xlUp ←この行は不要
  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
    Cells(lngCnt, 4).Activate 'D列を参照する
    'D列が空白で、日付・個人IDが下の行と同じなら
    If ActiveCell.Value = "" And _
    ActiveCell.Offset(0, -3).Value = ActiveCell.Offset(1, -3).Value And _
    ActiveCell.Offset(0, -2).Value = ActiveCell.Offset(1, -2).Value Then
      ActiveCell.Value = ActiveCell.Offset(1, 0).Text '下の退勤時間を書き込む
      ActiveCell.Offset(1, 0).EntireRow.Delete Shift:=xlUp '1行下を削除
    End If
  Next
  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlGuess


End Sub

【20569】Re:重複データの整理について
回答  [名前なし]  - 04/12/12(日) 12:46 -

引用なし
パスワード
   ▼m3 さん:
>最後に一つだけ質問させてください。
>テキストファイルから("日付", "個人ID", "出勤時間", "退勤時間")を
>毎日取り込む場合、新しいデータを
>例えばA1を起点に挿入し、ダウンシフトするものと思います。
>恐らく Range("A2").Insert Shift:=xlDown になると思います。
>マクロのどの部分で設定すればよいでしょうか?
>なかなか上手くいきません。
「途中に追加」ではなく「最下行に追加」のほうがいいと思います。
下のコードをご覧ください。
最新のものを上のほうに持ってきたいのであれば、一番最後の並べ替えで
日付を降順にすればよいでしょう。降順の指定は、マクロの記録で調べるか、
ヘルプをご覧ください。

>また、誤って同じデータを挿入した場合を考え
>重複データの削除設定も行いたいのですが、
>これは、1行下のデータが同じ場合、1行下を削除する。
>を最後に指定すればよいでしょうか?
その前に、「同じデータを取り込まないようにする」ほうがいいでしょう。(※)
例えば、取り込み済みのデータのテキストファイルを
(1)名前を変更する。(XXX.CSV→済XXX.CSV)
(2)保存先を変更する。(C:\XXX→C:\XXX\処理済)
(3)取り込んだら別シートに取り込んだデータファイル名を追加し、
 そこにファイル名が無いものだけ取り込む。

などなど。どれか1つでいいと思います。下のコードをご覧ください。
でも、実際のファイル名がどうなってるかわからないので、なんとも言えませんが。

>Sub 勤怠3()
>  Const cnsTITLE = "テキストファイル読み込み処理"
>  Const cnsFILTER = "全てのファイル (*.*),*.*"
>  Dim xlAPP As Application    ' Applicationオブジェクト
>  Dim intFF As Integer      ' FreeFile値
>  Dim strFILENAME As String    ' OPENするファイル名(フルパス)
>  Dim X(1 To 4) As Variant    ' 読み込んだレコード内容
>  Dim GYO As Long         ' 収容するセルの行
>  Dim lngREC As Long       ' レコード件数カウンタ
>
>  Set xlAPP = Application
>  xlAPP.StatusBar = "読み込むファイル名を指定して下さい。"
>  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
>    Title:=cnsTITLE)
>  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub
   '(3)の場合はここに(※)の処理。
>
>  intFF = FreeFile
>  Open strFILENAME For Input As #intFF
  'GYO = 1 ←を下のように変更し、最下行にするようにします。
   GYO = Cells(Cells.Rows.Count, 1).End(xlUp).Row
>  Do Until EOF(intFF)
>    lngREC = lngREC + 1
>    xlAPP.StatusBar = "読み込み中です....(" & lngREC & "レコード目)"
>    Input #intFF, X(1), X(2), X(3), X(4)
>    GYO = GYO + 1
>
>  Cells(GYO, 1) = X(1)       '第1項目をB1セルへ
>  Cells(GYO, X(3) + 2) = Format(X(2), "00:00")  '第2項目をB3 or B4セルへ
>  Cells(GYO, 2) = X(4)       '第4項目をB2セルへ
>
>  Loop
>  ' 指定ファイルをCLOSE
>  Close #intFF
   '(1)または(2)の場合はここに(※)の処理。
>  xlAPP.StatusBar = False
>  ' 終了の表示
>  Range("A1:D1").Value = Array("日付", "個人ID", "出勤時間", "退勤時間")
>  MsgBox "ファイル読み込みが完了しました。" & vbCr & _
>    "レコード件数=" & lngREC & "件", vbInformation, cnsTITLE
>  Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Header:=xlGuess
>
>  ' Range("D2").Delete Shift:=xlUp ←この行は不要
>  For lngCnt = Cells(Cells.Rows.Count, 1).End(xlUp).Row To 2 Step -1
>    Cells(lngCnt, 4).Activate 'D列を参照する
>    'D列が空白で、日付・個人IDが下の行と同じなら
>    If ActiveCell.Value = "" And _
>    ActiveCell.Offset(0, -3).Value = ActiveCell.Offset(1, -3).Value And _
>    ActiveCell.Offset(0, -2).Value = ActiveCell.Offset(1, -2).Value Then
>      ActiveCell.Value = ActiveCell.Offset(1, 0).Text '下の退勤時間を書き込む
>      ActiveCell.Offset(1, 0).EntireRow.Delete Shift:=xlUp '1行下を削除
>    End If
>  Next
>  Range("A1").CurrentRegion.Sort Key1:=Range("A1"), Header:=xlGuess
>
>
>End Sub

【20570】Re:重複データの整理について
お礼  m3  - 04/12/12(日) 14:46 -

引用なし
パスワード
   まだ重複データへの対処をどのようにするか
決定していませんが、だいぶ理想通りになってきました。
ありがとうございました。

【20571】Re:重複データの整理について
発言  [名前なし]  - 04/12/12(日) 14:52 -

引用なし
パスワード
   ▼m3 さん:
>また、誤って同じデータを挿入した場合を考え
>重複データの削除設定も行いたいのですが、

どうしてもこちらでやりたい場合は、日付と個人IDが

>これは、1行下のデータが同じ場合、1行下を削除する。
>を最後に指定すればよいでしょうか?

でいいと思います。これをするのは、最後に日付で並べ替えした後、
ループで処理することになります。ではがんばってください。

【20584】Re:重複データの整理について
質問  m3  - 04/12/12(日) 22:02 -

引用なし
パスワード
   >>また、誤って同じデータを挿入した場合を考え
>>重複データの削除設定も行いたいのですが、
>
>どうしてもこちらでやりたい場合は、日付と個人IDが
>
>>これは、1行下のデータが同じ場合、1行下を削除する。
>>を最後に指定すればよいでしょうか?
>
>でいいと思います。これをするのは、最後に日付で並べ替えした後、
>ループで処理することになります。ではがんばってください。

ありがとうございます。
実際試してみようと思い
loopとifを組み合わせて見ました。どこが悪いでしょうか?

  y = 1
  Do
  If Cells(y, 0).Value = Cells(y + 1, 0).Value And _
   Cells(y, 1).Value = Cells(y + 1, 1).Value Then
   
    Cells(y + 1, 0).EntireRow.Delete Shift:=xlUp '1行下を削除
    End If
    y = y + 1
    Loop Until Cells(y + 1, 1).Value = "" '空白なら終了

【20585】Re:重複データの整理について
回答  [名前なし]  - 04/12/12(日) 23:10 -

引用なし
パスワード
   ▼m3 さん:
Cells(行番号, 列番号)で指定しますので、
Cells(y, 0) ←列は1列目からなので、0列目は存在しませんよ。

【20589】Re:重複データの整理について
質問  m3  - 04/12/13(月) 0:23 -

引用なし
パスワード
   >Cells(行番号, 列番号)で指定しますので、
>Cells(y, 0) ←列は1列目からなので、0列目は存在しませんよ。


ありがとうございました。
なんか疲れているみたいです。

申し訳ありませんがもう1点戸惑っています。
シート1に下記の出退勤データが蓄積されています。

シート1
 日付   ID  出勤   退勤
20041206    11011001    7:50    21:30
20041205    11013008    8:30    19:23
 ・
 ・
 ・

シート2で
それを集計するべく
テキストボックスを用いて
テキストボックスに日付(yyyymmdd)を入力しボタンを押すことで
調べたい期間の出勤者数(日付の数)をカウントしたく思います。
恐らく出来ると思いますがマクロのイメージがつきません。
どうかアドバイスをお願いいたします。

yyyymmdd 〜 yyyymmdd の出勤者数  [ボタン]

   [ 結果 ]名

【20592】Re:重複データの整理について
回答  [名前なし]  - 04/12/13(月) 1:02 -

引用なし
パスワード
   ▼m3 さん:
>シート2で
>それを集計するべく
>テキストボックスを用いて
>テキストボックスに日付(yyyymmdd)を入力しボタンを押すことで
>調べたい期間の出勤者数(日付の数)をカウントしたく思います。
>恐らく出来ると思いますがマクロのイメージがつきません。
>どうかアドバイスをお願いいたします。
>
> yyyymmdd 〜 yyyymmdd の出勤者数  [ボタン]
>
>   [ 結果 ]名
オートフィルタをマクロの記録で記録して、それを使えばいいんじゃないでしょうか。
「最初の日付」以上 and 「2個目の日付」以下で指定すれば、指定した日付
のものだけ表示されますよね。それを
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Rows.Count - 1
としてやれば、数は出ます。(最後の-1は、タイトル行の分引いてます。)

ただ、この数え方はなにか気になります。
例えば、1日・2日の2日間、A,Bの2人しか出勤してない場合と、1日にA,B,C,Dの4人
が出勤して、2日は誰も出なかった場合、1日にA,Bの2人、2日はB、Cの2人の場合、
いずれも4名という結果になってしまいますがいいのでしょうか。

【20593】Re:重複データの整理について
お礼  m3  - 04/12/13(月) 1:16 -

引用なし
パスワード
   >オートフィルタをマクロの記録で記録して、それを使えばいいんじゃないでしょうか。
>「最初の日付」以上 and 「2個目の日付」以下で指定すれば、指定した日付
>のものだけ表示されますよね。

何度か試したのですが上手く出来ませんでした。
しかし不安が消えましたので再度挑戦してみます。

それを
>Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Rows.Count - 1
>としてやれば、数は出ます。(最後の-1は、タイトル行の分引いてます。)
>
>ただ、この数え方はなにか気になります。
>例えば、1日・2日の2日間、A,Bの2人しか出勤してない場合と、1日にA,B,C,Dの4人
>が出勤して、2日は誰も出なかった場合、1日にA,Bの2人、2日はB、Cの2人の場合、>いずれも4名という結果になってしまいますがいいのでしょうか。

ありがとうございます。
のべ人数が知りたいので問題ありません。

【20598】Re:重複データの整理について
回答  Jaka  - 04/12/13(月) 9:11 -

引用なし
パスワード
   こんにちは。
詳細はわからないけど、書いてきちゃったんで載せておきます。

Sub 勤怠3()
  Const cnsTITLE = "テキストファイル読み込み処理"
  Const cnsFILTER = "全てのファイル (*.*),*.*"
  Dim xlAPP As Application, strFILENAME As String
  Dim LsR As Long, Fdinf(1 To 4) As Variant, i As Long

  Set xlAPP = Application
  strFILENAME = xlAPP.GetOpenFilename(FileFilter:=cnsFILTER, _
    Title:=cnsTITLE)
  If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

  xlAPP.ScreenUpdating = False
  For i = 1 To 4
    Fdinf(i) = Array(i, 2)
  Next
  Workbooks.OpenText Filename:=strFILENAME, DataType:=xlDelimited, _
                 Comma:=True, FieldInfo:=Fdinf
  Erase Fdinf

  With ActiveSheet
    .UsedRange.Sort Key1:=.Range("C1"), Order1:=xlAscending, Key2:=.Range("D1") _
            , Order2:=xlAscending
    LsR = .Range("A65536").End(xlUp).Row
    With .Range("B1:B" & LsR)
       .Offset(, 4).Formula = "=LEFT(B1,2) & "":"" & RIGHT(B1,2)"
       .Offset(, 4).Value = .Offset(, 4).Value
       .Value = .Offset(, 4).Value
       .Offset(, 4).Clear
    End With
    .Rows(1).Insert Shift:=xlDown
    .Range("A1").Resize(, 4).Value = "WW"
    LsR = LsR + 1
    
    .Range("A1").AutoFilter Field:=3, Criteria1:="1"
    With .Range("A2:A" & LsR)
      filcct = .SpecialCells(xlCellTypeVisible).Count
      For i = 1 To 4
        Select Case i
          Case 1
           ThisWorkbook.Sheets("Sheet1").Range("A1").Resize(filcct).Value = _
                  .SpecialCells(xlCellTypeVisible).Value
          Case 2
           ThisWorkbook.Sheets("Sheet1").Range("C1").Resize(filcct).Value = _
                  .SpecialCells(xlCellTypeVisible).Offset(, i - 1).Value
          Case 4
           ThisWorkbook.Sheets("Sheet1").Range("B1").Resize(filcct).Value = _
                 .SpecialCells(xlCellTypeVisible).Offset(, i - 1).Value
        End Select
      Next
    End With
    DoEvents
    .Range("A1").AutoFilter Field:=3, Criteria1:="2"
    With .Range("A2:A" & LsR)
      filcct = .SpecialCells(xlCellTypeVisible).Count
      ThisWorkbook.Sheets("Sheet1").Range("D1").Resize(filcct).Value = _
            .SpecialCells(xlCellTypeVisible).Offset(, 1).Value
    End With
  End With
  Workbooks(Dir(strFILENAME)).Close False
  ThisWorkbook.Sheets("Sheet1").Range("C1", Range("C1").End(xlDown)).Resize(, 2).NumberFormatLocal = "hh"":""mm"
  xlAPP.ScreenUpdating = True
End Sub

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