文字操作 ファイル内文字付番置換
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Option Explicit Dim lngNo& Sub ファイル内文字付番置換() '*************************************************** '大量の同じ文字が記述されているファイルのその各同じ文字 'に番号を付ける '*************************************************** FileReadingAndWriting ThisWorkbook.Path & "\参照雛形\index.txt", "vbサムネイル", "vbサムネイル" End Sub Private Sub FileReadingAndWriting(対象ファイル$, 検索字$, 置換字$) '*************************************************** '大量の同じ文字が記述されているファイルのその各同じ文字 'に番号を付ける '*************************************************** Dim RetrievalCharacter$, ConversionCharacter$ Dim OriginalFile$, ReproductionFile$ Dim WritingFile As Integer, ReadingFile As Integer Dim strDAT$, lngCnt& 'パラメータ設定部---------------------------------------------------- '元のファイルフルパスとファイル名 OriginalFile = 対象ファイル 'コピーするファイルとファイル名 ReproductionFile = ThisWorkbook.Path & "\Copy" & Format(Date, "yymmdd") & Format(Time, "hhmmss") & ".txt" '検索文字 RetrievalCharacter = 検索字 '置換文字 ConversionCharacter = 置換字 '-------------------------------------------------------------------- 'エラーが発生した場合次のステートメントから実行継続 On Error Resume Next 'ファイルコピーの実行 FileCopy OriginalFile, ReproductionFile 'エラーが発生した場合 If Err <> 0 Then MsgBox "Error" & Err, vbCritical, "Error" Exit Sub End If '元のファイル削除 Kill OriginalFile '使用可能なファイル番号取得 WritingFile = FreeFile() Open ReproductionFile For Input As #WritingFile '使用可能なファイル番号取得 ReadingFile = FreeFile() Open OriginalFile For Output As #ReadingFile '変数初期化 lngCnt = 0 'グローバル変数の初期化 lngNo = 0 Do Until EOF(WritingFile) '最後(全て) 'ファイル読込 Line Input #WritingFile, strDAT '置換実行(Function)---------------↓対象文字列------↓検索文字------↓置換文字 lngCnt = lngCnt + FncstrReplace(strDAT, RetrievalCharacter, ConversionCharacter) 'ファイルに挿入 Print #ReadingFile, strDAT Loop 'それぞれのファイルを閉じる Close #WritingFile Close #ReadingFile '最初にコピーしたファイルを削除 Kill ReproductionFile End Sub Private Function FncstrReplace&(ByRef 対象文字列$, 検索文字$, 置換文字$) '*********************************************************************** '大量の指定文字を検索し順番に番号を付ける '*********************************************************************** Dim RetrievalResultPosition&, RetrievalBeginningNumber& Dim ReplacementCharacterNumber&, ConversionCharacterNumber& Dim strNO$ '重複防止検索開始番号初期化 RetrievalBeginningNumber = 1 'パラメータ設定 '置換え側[+ 3]は付ける番号の文字数又は桁数) ReplacementCharacterNumber = Len(置換文字) + 3 '検索側 ConversionCharacterNumber = Len(検索文字) Do '対象文字列の検索文字位置取得 RetrievalResultPosition = InStr(RetrievalBeginningNumber, 対象文字列, 検索文字, vbBinaryCompare) '検索文字が[0]の場合 If RetrievalResultPosition = 0 Then Exit Do FncstrReplace = FncstrReplace + 1 'グローバル変数の値を増加 lngNo = lngNo + 1 '付加する番号を３桁にする strNO = Format(lngNo, "00#") '置換 対象文字列 = Left$(対象文字列, RetrievalResultPosition - 1) & 置換文字 & strNO _ & Right$(対象文字列, Len(対象文字列) - RetrievalResultPosition - ConversionCharacterNumber + 1) '重複検索を防止 RetrievalBeginningNumber = RetrievalResultPosition + ReplacementCharacterNumber Loop End Function |