Excel VBA質問箱 IV

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

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


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

39099 / 76732

←次へ　｜　前へ→


	【42752】Re:重複値を、別ブックに書き出したい

Kein - 06/9/20(水) 17:06 -


	引用なし

	パスワード

ユーザーフォームを使わないコードです。このまま試してみて下さい。

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

1 hits

▼

【42748】重複値を、別ブックに書き出したい Palmer 06/9/20(水) 14:49