Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

10662 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【20493】重複データの整理について ｍ3 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】重複データの整理について

ｍ3 - 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の退勤時間は消滅してしまいます。
これが理解できません。
何故でしょうか？

２、
日付順に並べようと思い
並び替えのところを　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
になるはずです。そのため、下から５行目の
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,　　,
になってしまうため、コードを見直す必要があります。
>２、
>日付順に並べようと思い
>並び替えのところを　Key1:=Range("A1")　にしました。
>そうするとD列：退勤時間が同じ日付に対し1件しか表示しなくなります。
>何故でしょうか？
その状態が再現できるサンプルデータを教えていただけませんか？


	【20548】Re:重複データの整理について

m3 - 04/12/11(土) 22:39 -


	引用なし

	パスワード

ご返事ありがとうございます。

>>２、
>>日付順に並べようと思い
>>並び替えのところを　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 -


	引用なし

	パスワード

>>２、
>>日付順に並べようと思い
>>並び替えのところを　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
　　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 '１行下を削除
　　　　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 '１行下を削除
　　　　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)取り込んだら別シートに取り込んだデータファイル名を追加し、
　そこにファイル名が無いものだけ取り込む。

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

>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 '１行下を削除
>　　　　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 '１行下を削除
　　　 End If
　　　 y = y + 1
　　　　Loop Until Cells(y + 1, 1).Value = ""　'空白なら終了


	【20585】Re:重複データの整理について

[名前なし] - 04/12/12(日) 23:10 -


	引用なし

	パスワード

▼m3 さん：
Cells(行番号, 列番号)で指定しますので、
Cells(y, 0) ←列は１列目からなので、0列目は存在しませんよ。


	【20589】Re:重複データの整理について

m3 - 04/12/13(月) 0:23 -


	引用なし

	パスワード

>Cells(行番号, 列番号)で指定しますので、
>Cells(y, 0) ←列は１列目からなので、0列目は存在しませんよ。

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

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

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

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

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

　　　[　結果　]名


	【20592】Re:重複データの整理について

[名前なし] - 04/12/13(月) 1:02 -


	引用なし

	パスワード

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

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


	【20593】Re:重複データの整理について

m3 - 04/12/13(月) 1:16 -


	引用なし

	パスワード

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

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

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

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


	【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 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free