|
こんにちは。
詳細はわからないけど、書いてきちゃったんで載せておきます。
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
|
|