Excel VBA質問箱 IV

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

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


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

60770 / 76732

←次へ　｜　前へ→


	【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

1 hits

▼

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