【メモ】データを配列に格納、シートをコピーして、配列の内容を転記。

個人用のメモ。会社で30人以上のエクセルのPC関係事務手続き用のシートを作る必要があった。

• 「設定」シートにいろいろユーザー名等が記入されている。
• これを配列に格納。
• テンプレートのシートをコピーして、必要事項を配列から転記。
• シート名は配列内に格納した「使用者名」にする。
  シート名が重複していたら↓みたいに（２）といった番号をふる。
  /武田/武田(2)/鈴木/本田/本田(2)/本田(3)/・・・・

範囲を配列にする自作関数（Range2Array）、重複するシートの数を返す関数（Count_Duplicate）は他の場面でも使えるかなと思いました。

'★メインプロシージャ
Sub 設定シート作成()
'●設定シートのデータを配列に格納
Sheets("設定").Select
array_user = Range2Array(4, 9) '①自作Range2Array関数
'●配列の列
'1：ID
'2：使用者
'4：ユーザー名これがEmptyだったら転記しない
'5：所属
'7：モデル
'8：●●ソフト使用1 or 0
'9：▲▲ソフト使用1 or 0


For array_i = 1 To UBound(array_user)
    If array_user(array_i, 4) <> Empty Then '配列の「4:ユーザー名」が空でなければ以下実行。
    '●テンプレシートをコピーし、シート名を「2:使用者」に変更。
        Copy_Sheet (array_user(array_i, 2)) '②プロシージャ
    '●配列を新シートに転記
        Cells(4, 3) = Date
        Cells(5, 3) = "シート作成者"
        Cells(8, 9) = "新規"
        Cells(9, 9) = array_user(array_i, 7) '7：モデル
        Cells(10, 9) = array_user(array_i, 5) '5：所属
        Cells(11, 9) = array_user(array_i, 2) '2：使用者
        Cells(12, 9) = array_user(array_i, 4) '4：ユーザー名
        Cells(13, 9) = "Win10" 'OS
        Cells(14, 9) = array_user(array_i, 1) & ".id" '1：ID
        Cells(17, 9) = "Printer-3" '以下、プリンター名。
        Cells(18, 9) = "Printer-4"
        Cells(19, 9) = "Printer-5"
        Cells(20, 9) = "Printer-6"
        Cells(21, 9) = "Printer-7"
        '●●ソフト使用と▲▲ソフト使用にレ点(機種依存文字・文字コード)
        If array_user(array_i, 8) = 1 Then Cells(15, 9) = ChrW(&H2713)
        If array_user(array_i, 9) = 1 Then Cells(16, 9) = ChrW(&H2713)
    End If
Next
End Sub

'①範囲を配列にする関数（開始行、開始列）→2次元配列
Public Function Range2Array(begin_row As Long, begin_column As Long) As Variant
    last_row = Cells(begin_row, begin_column).End(xlDown).Row '終端行
    last_column = Cells(begin_row, begin_column).End(xlToRight).Column '終端列
    
    Range2Array = Range(Cells(begin_row, begin_column), Cells(last_row, last_column))
End Function

'②templateをコピーして、新規シート作成し、シート名変更（ユーザー名）
Public Sub Copy_Sheet(user_name As String)
Worksheets("テンプレート").Copy After:=Worksheets(Worksheets.Count)
N_Duplicate = Count_Duplicate(user_name) '③関数使用。重複してるシート名に(重複数)つける。
If N_Duplicate > 1 Then
    ActiveSheet.Name = user_name & "(" & N_Duplicate & ")"
Else
    ActiveSheet.Name = user_name
End If
End Sub

'③これから作成するシート、既にあるシート含めて何個同じ名前のシートあるかを返す。
Public Function Count_Duplicate(user_name As String)
Dim N_Duplicate As Integer
N_Duplicate = 1 '初期値はNは1
For i = 1 To Worksheets.Count
    If Sheets(i).Name = user_name Then
        N_Duplicate = N_Duplicate + 1 '重複あればNを1増やす。
    End If
Next i
Count_Duplicate = N_Duplicate
End Function

'★やり直してシート消すプロシージャ
Sub テンプレと設定以外のシート削除()
Application.DisplayAlerts = False
    For sheet_i = Worksheets.Count To 1 Step -1
        If Worksheets(sheet_i).Name = "テンプレート" Then 'テンプレートシートは消さない
            GoTo Continue
        End If
        
        If Worksheets(sheet_i).Name = "設定" Then '設定シートは消さない
            GoTo Continue
        End If
    Worksheets(sheet_i).Delete
Continue:
    Next sheet_i
Application.DisplayAlerts = True
End Sub