文字操作 ファイル内文字付番置換

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。


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
        
        '付加する番号を3桁にする
        strNO = Format(lngNo, "00#")
        
        '置換
        対象文字列 = Left$(対象文字列, RetrievalResultPosition - 1) & 置換文字 & strNO _
          & Right$(対象文字列, Len(対象文字列) - RetrievalResultPosition - ConversionCharacterNumber + 1)
        
        '重複検索を防止
        RetrievalBeginningNumber = RetrievalResultPosition + ReplacementCharacterNumber
    Loop
    
End Function

 

 

 

2000年01月01日|[VBサンプルコード]:[文字操作]