| |
最後に一つだけ質問させてください。
テキストファイルから（"日付", "個人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
|
|
m3
- 04/12/12(日) 12:02 -
