| |
ユーザーフォームを使わないコードです。このまま試してみて下さい。
Sub Fields_Check()
Dim MyF As String, TbN As String
Dim NewB As String, Buf As String
Dim Ary As Variant
Dim WB As Workbook
Dim MyR As Range
MyF = Application _
.GetOpenFilename("CSVファイル(*.csv),*.csv")
If MyF = "False" Then Exit Sub
TbN = Left$(Dir(MyF), Len(Dir(MyF)) - 4)
NewB = CurDir() & "\" & TbN & _
Format(Date, "yymmdd") & ".xls"
If Dir(NewB) <> "" Then
MsgBox "本日のファイルは作成済みです", 48: Exit Sub
End If
Open MyF For Input Access Read As #1
Line Input #1, Buf
Close #1: Ary = Split(Buf, ",")
Application.ScreenUpdating = False
Set WB = Workbooks.Add(xlWBATWorksheet)
With WB.Worksheets(1)
.Range("A1:B1").Value = Array("重複項目", "列番号")
Set MyR = .Range("A2").Resize(UBound(Ary) + 1)
MyR.Value = WorksheetFunction.Transpose(Ary)
With .Range("B2")
.Value = 1: .AutoFill MyR.Offset(, 1), xlLinearTrend
End With
On Error Resume Next
With MyR.Offset(, 255)
.Formula = "=IF(COUNTIF($A:$A,$A2)=1,1)"
.SpecialCells(3, 1).EntireRow.Delete xlShiftUp
.ClearContents
End With
On Error GoTo 0
.Range("A1").CurrentRegion.Sort Key1:=.Range("A1"), _
Order1:=xlAscending, Key2:=.Range("B1"), Order2:= _
xlAscending, Header:=xlYes, Orientation:=xlSortColumns
.Name = TbN
End With
WB.SaveAs NewB: Set WB = Nothing: Set MyR = Nothing
Application.ScreenUpdating = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
