| |
▼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
|
|
[名前なし]
- 04/12/12(日) 12:46 -
