[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『括弧内文字削除のマクロで質問』（まっつん）
テキストファイル内の括弧内の文字列（括弧も含んで）を削除して別名で保存するマクロを作成中です。
下記マクロですが、問題があるのでアドバイスをお願いします。
「'括弧内文字列削除(括弧も含む）」で書き出し自体は上手く処理されていますが
ファイル名相当のシートに書き出されるので「'新規に修正ファイルをテキストファイルに書き出す」では
sheet1を対象にしているのでこのままでは上手く処理できない
どのように整合すれば良いのか ？
Columns("A").Selectを選択して処理していますが
A列が5000行と大きいのが原因なのか？
処理時間がすごく必要で暫くハング状態になる。
Application.ScreenUpdating = False を入れてみましたが目に見えた効果がありません。
Option Explicit
Sub 括弧内文字削除()
'
'ダイアログでターゲットファイル（ｔｘｔ)を選択（読み込み) ---------------
Dim FileName As Variant
Dim FileName2 As String
Dim FilePath As String
Dim fso As New FileSystemObject
FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.txt")
If FileName = False Then
Exit Sub
End If
'ターゲットファイルの拡張子無しのファイル名を取得
FileName2 = fso.GetBaseName(FileName)
'ターゲットファイルのパス取得
FilePath = Replace(FileName, Dir(FileName), "")
Workbooks.Open FileName
'括弧内文字列削除(括弧も含む）--------------------------------
Dim RegExp As Object
Dim Cell As Range
'
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "[（(].*[)）]"
'
Application.ScreenUpdating = False
Columns("A").Select
For Each Cell In Selection
Cell = RegExp.Replace(Cell, "")
Next
'新規に修正ファイルをテキストファイルに書き出す -------------
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
Dim datFile As String
datFile = FilePath & FileName2 & "_mod.txt"
Open datFile For Output As #1
Dim i As Long
Stop
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
Print #1, ws.Cells(i, "A").Value
Next
Close #1
Application.ScreenUpdating = True
MsgBox datFile & "に書き出しました"
End Sub
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
シートの名前の整合は、Set ws = Worksheets(FileName2) で良さそうです。
後は、高速化が残っています。
（まっつん） 2023/10/18(水) 11:29:18
Columns("A").Select
For Each Cell In Selection
Cell = RegExp.Replace(Cell, "")
Next
これだと、A列の最終行の A1048576セルまで、たとえ空白でも置換を実行します
書き出すときに、
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
Print #1, ws.Cells(i, "A").Value
Next
としているように、データが入っている最終行までを処理の対象にすべきです。
また、１セル毎に値を書き換えていると、かなり時間が掛かります。 以下のようにすると結構早くなると思います。
Sub sample()
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "[（(].*[)）]"
Dim buf
With Range("A1", Cells(Rows.Count, "A").End(xlUp))
buf = .Value
For i = 1 To UBound(buf)
buf(i, 1) = RegExp.Replace(buf(i, 1), "")
Next
.Value = buf
End With
End Sub
（´・ω・`） 2023/10/18(水) 11:53:02
Range(Cells(1, 1), Cells(tr, 1)).Select
これで十分高速化したので満足ですが
何かコードで変更すべき点があればアドバイスお願いします。
と書いて投稿しようとしたら´・ω・`さんからアドバイスがありました。
ありがとうございます。
ご指摘の点、コードに反映したいと思います。
現時点では。
シートが2個（テキストファイル名、xlsm名）が出来てしまうのが気になります。
Option Explicit
Sub 括弧内文字削除()
'
'ダイアログでターゲットファイル（ｔｘｔ)を選択（読み込み) ---------------
Dim FileName As Variant
Dim FileName2 As String
Dim FilePath As String
Dim fso As New FileSystemObject
FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.txt")
If FileName = False Then
Exit Sub
End If
'ターゲットファイルの拡張子無しのファイル名を取得
FileName2 = fso.GetBaseName(FileName)
'ターゲットファイルのパス取得
FilePath = Replace(FileName, Dir(FileName), "")
Workbooks.Open FileName
'括弧内文字列削除(括弧も含む）--------------------------------
Dim RegExp As Object
Dim Cell As Range
Dim tr As Long
'
tr = Cells(Rows.Count, "A").End(xlUp).Row
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "[（(].*[)）]"
'
Application.ScreenUpdating = False
Range(Cells(1, 1), Cells(tr, 1)).Select
For Each Cell In Selection
Cell = RegExp.Replace(Cell, "")
Next
'新規に修正ファイルをテキストファイルに書き出す -------------
Dim ws As Worksheet
Set ws = Worksheets(FileName2)
Dim datFile As String
datFile = FilePath & FileName2 & "_mod.txt"
Open datFile For Output As #1
Dim i As Long
For i = 1 To tr
Print #1, ws.Cells(i, "A").Value
Next
Close #1
Application.ScreenUpdating = True
MsgBox datFile & "に書き出しました"
End Sub
（まっつん） 2023/10/18(水) 12:01:41
最後のように書き換えてみましたが
MsgBox datFile & "に書き出しました" & vbCrLf & _
"処理が終了したのでEXCELを閉じて終了です。"
ThisWorkbook.Close SaveChanges:=False
End Sub
マクロが終了しても最初に読み込んだファイル名（FileName）のシートが残ってEXCELが終了しません。
FileName = Application.GetOpenFilename
マクロが終了したらきれいにEXCELも終了する方法はありませんか ？
（まっつん） 2023/10/18(水) 15:16:39
MsgBox datFile & "に書き出しました" & vbCrLf & _
"処理が終了したのでEXCELを閉じて終了です。"
ActiveWorkbook.Close SaveChanges:=False
ThisWorkbook.Close SaveChanges:=False
Application.Quit
これでもVBAを見るとPERSONAL＿XLSBがあるので
アドインが起動しているようで
ワークシートは無い真っ黒の状態が表示されています。
PERSONAL＿XLSBを含めて
EXCELを終了させる方法はありませんか ？
（まっつん） 2023/10/18(水) 16:10:22
以下参考にして
https://www.excel.studio-kazu.jp/kw/20040414114513.html
順番を変更してEXCELが終了しました。
MsgBox datFile & "に書き出しました" & vbCrLf & _
"処理が終了したのでEXCELを閉じて終了です。"
'// Excelを終了する
Application.Quit
ActiveWorkbook.Close SaveChanges:=False
ThisWorkbook.Close SaveChanges:=False
（まっつん） 2023/10/18(水) 16:40:17
（もこな２ ） 2023/10/20(金) 08:49:44
■１
↓は何を目的としていますか？
Workbooks.Open FileName
最終的に↓で１行ずつ書き出していますから、そもそもブックとして開く（シート上に展開する）必要はないように思います。
Open datFile For Output As #1
したがって、例えば↓のようなことでも期待する結果になると思います。
Sub 研究用1()
Dim ファイルパス As String, tmp As String
Dim FF1 As Long, FF2 As Long
Dim RegExp As Object
FF1 = FreeFile
ファイルパス = Application.GetOpenFilename(FileFilter:="テキストファイル,*.txt")
If ファイルパス = "False" Then Exit Sub
Open ファイルパス For Input As #FF1
FF2 = FreeFile
Open Left(ファイルパス, Len(ファイルパス) - 4) & "_mod.txt" For Output As #FF2
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Global = True
RegExp.Pattern = "[（(].*[)）]"
Do Until EOF(1)
Line Input #FF1, tmp
Print #FF2, RegExp.Replace(tmp, "")
Loop
Close #FF1
Close #FF2
End Sub
■２
また、シート上に展開するならばそれはそれで、１セルずつ処理するのではなくReplaceメソッドで一括処理すれば、さほど時間はかからないように思います。
■３
＞〜PERSONAL＿XLSBがあるので〜
ブックとして開くにせよ、自ブックのシート上に展開（インポート）するにせよ、そのブックのSavedをTrueにしてから、ExcelをQuitすればよいと思います。
（テキストファイルを出力したら用なしですよね？）
（もこな２ ） 2023/10/20(金) 12:18:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.