無限不可能性ドライブ

『ニューラルネットワーク自作入門』に刺激されてExcelVBAでニューラルネットワークを作ってみたものの、やっぱり数学やらなきゃと思い少しずつやってきたのもあって、自分の知識の整理とかそういった感じです。

【VBA】リネームする

面白そうだったのでチャレンジしてみました。


f:id:celaeno42:20210405235637p:plain


ワークシートはこんな感じ
f:id:celaeno42:20210405235947p:plain:w420

[標準モジュール]
Option Explicit

Const CL_CHK As Long = 3

Public Sub Click_ランダムソート()
    Dim r As Long
    Dim lastRow As Long
    Dim destRow As Long

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 2), Cells(lastRow, 2)).ClearContents
    
    Randomize
    
    For r = 2 To lastRow
        Do
            destRow = Int((lastRow - 2 + 1) * Rnd + 2)
        Loop Until Cells(destRow, 2).Value = ""
    
        Cells(destRow, 2).Value = Cells(r, 1).Value
    
    Next

End Sub

Public Sub Click_リネーム()
    Dim folderPath As String
    
    folderPath = "C:\Users\xxxx\Desktop\rename\files"
    
    Columns(CL_CHK).ClearContents
    
    Call renameFiles(folderPath, 1, 2)
    
    Columns(CL_CHK).ClearContents
    
End Sub


Public Sub Click_ファイル名を戻す()
    Dim folderPath As String
    
    folderPath = "C:\Users\xxxx\Desktop\rename\files"
    
    Columns(CL_CHK).ClearContents
    
    Call renameFiles(folderPath, 2, 1)
    
    Columns(CL_CHK).ClearContents
    
End Sub

Private Sub renameFiles(ByRef folderPath As String, _
                        ByRef colSource As Long, ByRef colDest As Long)
    Dim cnt As Long         '処理済みカウント
    Dim cntFiles As Long    '処理対象ファイル数
    Dim r As Long
    Dim lastRow As Long
    Dim bufFileName As String  'ファイル名退避用
    Dim srcFileName As String   'リネーム前のファイル名
    Dim destFileName As String  'リネーム後のファイル名
    
    '一時ファイル名
    '何らかの処理で使われていないファイル名にする必要があるが、
    '今回は簡単のため temp.txt とした
    Const TMP_FNAME As String = "temp.txt"
    
    lastRow = Cells(Rows.Count, colSource).End(xlUp).Row
    cntFiles = lastRow - 1
    
    cnt = 0
    Do
        r = 2
        
        '未処理ファイル名の最初のものを temp.txt にリネームする
        '元のファイル名を bufFileName に格納する
        Do
            If Cells(r, CL_CHK).Value = "" Then
                bufFileName = Cells(r, colSource).Value
                Call renameFile(folderPath, bufFileName, TMP_FNAME)
                Exit Do
            End If
            
            r = r + 1
        Loop
        
        destFileName = bufFileName
        
        Do
            'リネーム後のファイル名のある行を探す
            r = getRow(destFileName, colDest, lastRow)
            
            If Cells(r, colSource).Value <> bufFileName Then
                'その行にある元のファイル名が bufFileName でなかったら
                'その行の元のファイル名をリネームして
                'destFileName に元のファイル名を格納する
                srcFileName = Cells(r, colSource).Value
                Call renameFile(folderPath, srcFileName, destFileName)
                Cells(r, CL_CHK).Value = 1
                destFileName = srcFileName
                cnt = cnt + 1
            Else
                '元のファイル名が bufFileName と同じなら
                'temp.txt としていたファイルをリネームして
                '一連の処理を終了し、再度先頭から未処理ファイル名のものを処理する
                Call renameFile(folderPath, TMP_FNAME, Cells(r, colDest).Value)
                Cells(r, CL_CHK).Value = 1
                cnt = cnt + 1
                Exit Do
            End If
        
        Loop
        
    Loop While cnt < cntFiles

End Sub

Private Sub renameFile(ByRef folderPath As String, _
                        ByRef srcFileName As String, ByRef destFileName As String)
    Dim fso As Object
    Dim f As Object
    
    Set fso = CreateObject("Scripting.FilesystemObject")
    Set f = fso.GetFile(folderPath & "\" & srcFileName)
    f.Name = destFileName
    
    Set f = Nothing
    Set fso = Nothing
    
End Sub

Private Function getRow(ByRef fileName As String, _
                        ByRef colTarget As Long, ByRef lastRow As Long) As Long
    Dim r As Long
    
    For r = 2 To lastRow
        If Cells(r, colTarget).Value = fileName Then
            getRow = r
            Exit For
        End If
    Next
End Function



f:id:celaeno42:20181212233850p:plain