🏮

【VBA】各自治体の様式を同じブックのシートに保存するとき、リネームして保存する

2023/06/28に公開

Excel

各自治体の様式を同じブックに保存したいとき、シート名は01千代田区、02中央区、…と揃えたいですよね。
ファイル名（フォルダパスを含む）にその自治体名を含む場合、リネームしてシート名を返すコードになります。

Function SetSheetsName(fileName As String) As String
'-----------------------------------------
'
'ファイル名に自治体名が入っていれば
'01千代田区のようなシート名にする。
'
'-----------------------------------------
    
     If InStr(fileName, "千代田") > 0 Then
         SetSheetsName = "01千代田区"
     ElseIf InStr(fileName, "中央") > 0 Then
         SetSheetsName = "02中央区"
     ElseIf InStr(fileName, "港") > 0 Then
         SetSheetsName = "03港区"
     ElseIf InStr(fileName, "新宿") > 0 Then
         SetSheetsName = "04新宿区"
     ElseIf InStr(fileName, "文京") > 0 Then
         SetSheetsName = "05文京区"
     ElseIf InStr(fileName, "台東") > 0 Then
         SetSheetsName = "06台東区"
     ElseIf InStr(fileName, "墨田") > 0 Then
         SetSheetsName = "07墨田区"
     ElseIf InStr(fileName, "江東") > 0 Then
         SetSheetsName = "08江東区"
     ElseIf InStr(fileName, "品川") > 0 Then
         SetSheetsName = "09品川区"
     ElseIf InStr(fileName, "目黒") > 0 Then
         SetSheetsName = "10目黒区"
     ElseIf InStr(fileName, "大田") > 0 Then
         SetSheetsName = "11大田区"
     ElseIf InStr(fileName, "世田谷") > 0 Then
         SetSheetsName = "12世田谷区"
     ElseIf InStr(fileName, "渋谷") > 0 Then
         SetSheetsName = "13渋谷区"
     ElseIf InStr(fileName, "中野") > 0 Then
         SetSheetsName = "14中野区"
     ElseIf InStr(fileName, "杉並") > 0 Then
         SetSheetsName = "15杉並区"
     ElseIf InStr(fileName, "豊島") > 0 Then
         SetSheetsName = "16豊島区"
     ElseIf InStr(fileName, "北区") > 0 Then
         SetSheetsName = "17北区"
     ElseIf InStr(fileName, "荒川") > 0 Then
         SetSheetsName = "18荒川区"
     ElseIf InStr(fileName, "板橋") > 0 Then
         SetSheetsName = "19板橋区"
     ElseIf InStr(fileName, "練馬") > 0 Then
         SetSheetsName = "20練馬区"
     ElseIf InStr(fileName, "足立") > 0 Then
         SetSheetsName = "21足立区"
     ElseIf InStr(fileName, "葛飾") > 0 Then
         SetSheetsName = "22葛飾区"
     ElseIf InStr(fileName, "江戸川") > 0 Then
         SetSheetsName = "23江戸川区"
     'ファイル名に市町村名を含まない場合は末尾10文字をシート名にする
     Else
        'シート名に使えない文字列が含まれていれば削除する
        fileName = DeleteInvalidChars(fileName)
        SetSheetsName = Right(fileName, 10)
     End If
    
End Function

Function DeleteInvalidChars(fileName As String) As String
'シート名で扱えない文字列が含まれているときは削除する

    Dim invalidChars As String
    Dim i As Long

    invalidChars = "/\?*:[]"
    DeleteInvalidChars = fileName ' 元のファイル名を初期値として設定
    
    For i = 1 To Len(invalidChars)
        DeleteInvalidChars = Replace(DeleteInvalidChars, Mid(invalidChars, i, 1), "")
    Next i
    
End Function

SetSheetsNameではファイルパスからシート名を判定するので、例えば足立区フォルダに入っている様式01.xlsxというファイルは21足立区というシート名になります。
どの候補にもマッチしなかった場合は末尾10文字をシート名としています。
DeleteInvalidCharで使用できない文字を削除しています。

使い方

Sub test()
    Dim selectedFile As FileDialog
    Dim filePath As String
    Dim sourceWorkbook As Workbook
    Dim sourceSheet As Worksheet
    
    ' ファイルを選択するダイアログを表示
    Set selectedFile = Application.FileDialog(msoFileDialogFilePicker)
    selectedFile.AllowMultiSelect = False
    ' 選択したファイルのパスを取得
    If selectedFile.Show = -1 Then 
        filePath = selectedFile.SelectedItems(1) 
        
        ' 選択したファイルを開く
        Set sourceWorkbook = Workbooks.Open(filePath)
        
        ' 選択したファイルの一番目のシートを取得
        Set sourceSheet = sourceWorkbook.Sheets(1)
        
        ' 新しいシートを作成し、選択したファイルのシートをコピー
        sourceSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = SetSheetsName(filePath)
        
        ' 選択したファイルを閉じる（保存しない）
        sourceWorkbook.Close SaveChanges:=False

    End If
End Sub

ダイアログからファイルパスを取得し、Thisworkbookの末尾に選択したエクセルファイルの1番目のシートをコピーします。

使い方

Discussion