Excel VBAサンプル

Option Explicit
Sub シート_区切り無し()
    If Range("A1").Value = "" Then        Range("A1").Value = "x"    End If        Range("A1").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _        :=Array(1, 2), TrailingMinusNumbers:=True        If Range("A1").Value = "x" Then        Range("A1").Value = ""    End If    End Sub
Sub シート_vba編集()
    Dim s As Worksheet    Dim i As Long    Dim r_end As Long        Set s = ActiveSheet    With s.UsedRange        r_end = .Row + .Rows.Count - 1    End With        If s.Cells(1, 1).Value <> "●" Then        s.Range("A1").EntireRow.Insert        s.Range("A1").EntireColumn.Insert        s.Range("A1").EntireColumn.Insert        s.Cells(1, 1) = "●"        s.Cells(1, 2) = "分類"        s.Cells(1, 3) = "コード"    End If        Call シート_テーブル化        s.Range(s.Cells(2, 1), s.Cells(r_end, 2)).ClearContents        For i = 2 To r_end            If InStr(1, s.Cells(i, 3).Value, "Sub ") > 0 Then            s.Cells(i, 1).Value = "●"            s.Cells(i, 2).Value = "Sub"            With s.Range(s.Cells(i, 1), s.Cells(i, 3)).Interior                .Pattern = xlSolid                .PatternColorIndex = xlAutomatic                .Color = 49407 '橙                .TintAndShade = 0                .PatternTintAndShade = 0            End With        End If                If InStr(1, s.Cells(i, 3).Value, "Function ") > 0 Then            s.Cells(i, 1).Value = "●"            s.Cells(i, 2).Value = "Function"            With s.Range(s.Cells(i, 1), s.Cells(i, 3)).Interior                .Pattern = xlSolid                .PatternColorIndex = xlAutomatic                .Color = 49407 '橙                .TintAndShade = 0                .PatternTintAndShade = 0            End With        End If                If InStr(1, s.Cells(i, 3).Value, "Dim ") > 0 Then            s.Cells(i, 2).Value = "Dim"            With s.Range(s.Cells(i, 3), s.Cells(i, 3)).Interior                .Pattern = xlSolid                .PatternColorIndex = xlAutomatic                .ThemeColor = xlThemeColorAccent1 '青                .TintAndShade = 0.8                .PatternTintAndShade = 0            End With        End If                If Left(s.Cells(i, 3).Value, 1) = "'" Then            s.Cells(i, 2).Value = "''"            With s.Cells(i, 3).Interior                .Pattern = xlSolid                .PatternColorIndex = xlAutomatic                .ColorIndex = 15 '灰                .TintAndShade = 0                .PatternTintAndShade = 0            End With            If s.Cells(i - 1, 3).Value = "" And Left(s.Cells(i - 2, 3).Value, 1) = "'" Then                With s.Cells(i - 1, 3).Interior                    .Pattern = xlSolid                    .PatternColorIndex = xlAutomatic                    .ColorIndex = 15 '灰                    .TintAndShade = 0                    .PatternTintAndShade = 0                End With            End If        End If        Next i
    s.Cells.EntireColumn.AutoFit
End Sub
Sub シート_テーブル化()
    Dim w_range As Range    Dim w_str As String        On Error Resume Next    ActiveSheet.ListObjects(1).Unlist    On Error GoTo 0        If Selection(1).Value = "" Then        Selection(1).Value = "AAA"    End If        If Selection.Rows.Count = 1 And Selection.Columns.Count = 1 Then        ActiveSheet.UsedRange.Select        Cells.ColumnWidth = 2    ElseIf Selection.Rows.Count > ActiveSheet.UsedRange.Rows.Count Or Selection.Columns.Count > ActiveSheet.UsedRange.Columns.Count Then        ActiveSheet.UsedRange.Select        Cells.ColumnWidth = 2    End If        With Selection.Interior        .Pattern = xlNone        .TintAndShade = 0        .PatternTintAndShade = 0    End With        With Selection.Font        .Size = 12    End With        Selection.Font.Bold = False        With Selection.Font        .Size = 12    End With        Selection.Borders(xlDiagonalDown).LineStyle = xlNone    Selection.Borders(xlDiagonalUp).LineStyle = xlNone    Selection.Borders(xlEdgeLeft).LineStyle = xlNone    Selection.Borders(xlEdgeTop).LineStyle = xlNone    Selection.Borders(xlEdgeBottom).LineStyle = xlNone    Selection.Borders(xlEdgeRight).LineStyle = xlNone    Selection.Borders(xlInsideVertical).LineStyle = xlNone    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone        w_str = "t_" & ActiveSheet.name    ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).name = w_str    ActiveSheet.ListObjects(w_str).TableStyle = "TableStyleMedium13"
    Range(w_str).Select    With Selection        .HorizontalAlignment = xlGeneral        .VerticalAlignment = xlTop        .Orientation = 0        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With        With Rows("1:1")        .HorizontalAlignment = xlLeft        .VerticalAlignment = xlTop        .WrapText = False                If ActiveSheet.ListObjects(w_str).ListColumns.Count > 20 Then            .Orientation = xlVertical        End If                .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With
    Range(w_str & "[#All]").Select    Selection.ColumnWidth = 50    Selection.Columns.AutoFit    Selection.Rows.AutoFit        For Each w_range In ActiveSheet.ListObjects(w_str).HeaderRowRange        Select Case w_range.Value        Case "日付", "作成日", "更新日"            w_range.EntireColumn.NumberFormatLocal = "yyyy-mm-dd;@"            w_range.EntireColumn.AutoFit            ActiveSheet.DisplayPageBreaks = False        End Select    Next w_range        On Error GoTo l_wnd    Range("t_時間集計[#Headers]").Select    With Selection        .HorizontalAlignment = xlLeft        .VerticalAlignment = xlTop        .WrapText = False        .Orientation = xlVertical        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With    Range("t_時間集計[#All]").Select    Selection.Columns.AutoFit    l_end:        Rows("2:2").Select    ActiveWindow.FreezePanes = True        Range("A1").Select
End Sub
Sub シート_一覧調整()        Cells.ColumnWidth = 2        Rows("1:1").Select    With Selection        .HorizontalAlignment = xlLeft        .VerticalAlignment = xlTop        .WrapText = False        .Orientation = xlVertical        .AddIndent = False        .IndentLevel = 0        .ShrinkToFit = False        .ReadingOrder = xlContext        .MergeCells = False    End With        Rows("2:2").Select    ActiveWindow.FreezePanes = True        Cells.Select    Selection.AutoFilter    Selection.Columns.AutoFit        Range("A1").Select    End Sub

Sub シート_表示()        Dim w_sheet As Worksheet        If ActiveWorkbook.ProtectStructure Then        MsgBox "ブックの保護を解除してください"        Exit Sub    End If        For Each w_sheet In ActiveWorkbook.Sheets                w_sheet.Visible = xlSheetVisible            Next w_sheet
End Sub
Sub シート_非表示()        Dim w_sheet As Worksheet        For Each w_sheet In ActiveWorkbook.Sheets                Select Case w_sheet.Name                Case "入力説明", "入力シート", "入力選択肢"                Case Else            w_sheet.Visible = xlSheetHidden                    End Select            Next w_sheet
End Sub

セル

Option Explicit
Sub セル_フォント赤()
    Dim w_len As Integer
    If Selection(1).Font.Color = 255 Then            With Selection.Font            .ThemeColor = xlThemeColorLight1 '黒            .TintAndShade = 0        End With            Else            With Selection.Font            .Color = 255 '赤            .TintAndShade = 0        End With            End If    End Sub
Sub セル_入力規則()        With Selection.Validation        .Delete        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="●,△,×,－"        .IgnoreBlank = True        .InCellDropdown = True        .InputTitle = ""        .ErrorTitle = ""        .InputMessage = ""        .ErrorMessage = ""        .IMEMode = xlIMEModeNoControl        .ShowInput = True        .ShowError = False    End With    End Sub
Sub セル_日付チェック()        Dim s As Worksheet    Dim r_end As Long    Dim w_range As Range        Set s = ActiveSheet    With s.UsedRange        r_end = .Row + .Rows.Count - 1    End With        On Error Resume Next    ActiveSheet.ShowAllData    On Error GoTo 0        For Each w_range In Selection            If w_range.Row > r_end Then            Exit For        End If            If w_range <> "" And IsDate(w_range) Then            If w_range.Interior.ColorIndex = xlNone And w_range.Interior.ThemeColor = xlNone Then                    If w_range > DateAdd("m", -6, Date) Then                    w_range.Interior.ColorIndex = 6                                ElseIf w_range > DateAdd("y", -1, Date) Then                    With w_range.Interior                        .Pattern = xlSolid                        .PatternColorIndex = xlAutomatic                        .ThemeColor = xlThemeColorAccent4 '薄黄                        .TintAndShade = 0.8                        .PatternTintAndShade = 0                    End With                                ElseIf w_range > DateAdd("m", -18, Date) Then                    With w_range.Interior                        .Pattern = xlSolid                        .PatternColorIndex = xlAutomatic                        .ThemeColor = xlThemeColorAccent4 '薄黄                        .TintAndShade = 0.8                        .PatternTintAndShade = 0                    End With                                End If                    End If        End If            Next w_range
End Sub
Sub セル_日付書式()        On Error Resume Next    ActiveSheet.ShowAllData    On Error GoTo 0        If Selection.NumberFormatLocal = "yyyy-mm-dd" Then        Selection.NumberFormatLocal = "yyyy""年""mm""月""dd""日"""    Else        Selection.NumberFormatLocal = "yyyy-mm-dd"    End If        Selection.EntireColumn.AutoFit
    ActiveSheet.DisplayPageBreaks = False
End Sub
Sub セル_タブ変換()        Dim cls As Range    Dim spa As String        For Each cls In Selection.Cells        spa = cls.Value        spa = Replace(spa, vbTab, " ")        cls.Value = "'" & spa    Next
End Sub
Sub セル_上をコピー()
    If ActiveCell.Value = "" Then        ActiveCell.Value = ActiveCell.Offset(-1, 0)    Next
End Sub
Sub セル_文字列()        Selection.NumberFormatLocal = "@"        If MsgBox("区切り無しにしますか？", vbYesNoCancel) = vbYes Then        Call シート_区切り無し    End If    End Sub
Sub セル_空白削除()
    Dim w_cell As Range    Dim j As Integer        For Each w_cell In Selection                If w_cell.Value = "" Then            If Selection.Columns.Count > 0 Then                w_cell.Delete Shift:=xlToLeft            Else                w_cell.Delete Shift:=xlUp            End If        End If
    Next w_cell
End Sub
Sub セル_行列入れ替え()
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End Sub

テスト

Option Explicit
Sub aaa()
Dim w_aaa(5) As String w_aaa(1) = "aaa" w_aaa(2) = "bbb" w_aaa(3) = "ccc" w_aaa(4) = "" w_aaa(5) = "ddd"
MsgBox Join(w_aaa, "")
End Sub

ファイル

Option Explicit
Sub ファイル_フォルダチェック()
    Dim w_fso As Object    Dim w_str As String
    Set w_fso = CreateObject("Scripting.FileSystemObject")
    w_str = InputBox("フォルダ名")
    If w_fso.FolderExists(w_str) = False Then        MsgBox "指定された入力フォルダは存在しません。", vbExclamation    Else        MsgBox "指定された入力フォルダは存在します。", vbInformation    End If
End Sub

Sub ファイル_フォルダ情報取得()        Dim r_start As Long    Dim r_end As Long    Dim c_end As Long    Dim w_range As Range    Dim w_active As Range    Dim i1 As Integer    Dim w_ret As Integer    Dim w_timer As Single        w_timer = Timer        Set fso = New FileSystemObject ' インスタンス化        Set s = ActiveSheet    Set w_active = ActiveCell        r_start = Selection.Row        If IsNumeric(s.Cells(1, 1).Value) And s.Cells(r_start, 3).Value <> "フォルダ" Then            If s.Cells(r_start, 1).Value > 1 Then            MsgBox "種類が ""フォルダ""の行で、実行してください。"            Exit Sub        End If        ElseIf s.Cells(r_start, 3).Value = "ファイルフォルダー" And s.Cells(r_start, 6).Value <> "" Then                If s.Cells(r_start + 1, 1).Value > s.Cells(r_start, 1).Value Then            MsgBox "すでに展開済みです。"            Exit Sub        End If                i = 0        Call f_フォルダ情報取得(s.Cells(r_start, 1).Value + 1, s.Cells(r_start, 6).Value)                Call f_配列ソート                If i > 0 Then                    s.Range(s.Rows(r_start + 1), s.Rows(r_start + i)).EntireRow.Insert            s.Range(s.Cells(r_start + 1, 1), s.Cells(r_start + i, 6)).Value = WorksheetFunction.Transpose(table)                    With s.UsedRange                r_end = .Row + .Rows.Count - 1                c_end = .Column + .Columns.Count - 1            End With                        For i = r_start + 1 To r_start + i                                If s.Cells(i, 1).Value > 1 Then                    s.Cells(i, 1).IndentLevel = (s.Cells(i, 1).Value - 1)                    s.Cells(i, 2).IndentLevel = (s.Cells(i, 1).Value - 1) * 2                End If
                If s.Cells(i, 3) = "ファイルフォルダー" Then                                    If s.Cells(i, 1).Value = 1 Then                                    ElseIf s.Cells(i, 1).Value = 2 Then                        With s.Range(s.Cells(i, 1), s.Cells(i, 6)).Interior                            .Pattern = xlSolid                            .PatternColorIndex = xlAutomatic                            .ThemeColor = xlThemeColorAccent6 '緑                            .TintAndShade = 0.6                            .PatternTintAndShade = 0                        End With
                    Else                        With s.Range(s.Cells(i, 1), s.Cells(i, 6)).Interior                            .Pattern = xlSolid                            .PatternColorIndex = xlAutomatic                            .ThemeColor = xlThemeColorDark2 '灰                            .TintAndShade = 0                            .PatternTintAndShade = 0                        End With                                End If                                    ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(i, 6), Address:=s.Cells(i, 6).Value, TextToDisplay:=s.Cells(i, 6).Value                                End If                        Next i                        s.Range(s.Cells(2, 1), s.Cells(r_end, c_end)).Select            Selection.ColumnWidth = 50            Selection.Columns.AutoFit            Selection.Rows.AutoFit                        Call グループ化                End If                w_active.Select        Else            r_start = 2            If s.Cells(1, 1).Value = "" Then            MsgBox "対象のパスを""A1""に設定してください。"            Exit Sub        End If                w_ret = MsgBox("頭から作り直しますが、良いですか？", vbOKCancel)        If w_ret = vbCancel Then            Exit Sub        End If            On Error Resume Next        ActiveSheet.ListObjects(1).Unlist        On Error GoTo 0                With s.UsedRange            r_end = .Row + .Rows.Count - 1        End With                On Error Resume Next        s.Name = Format(Now, "mm月dd日")        If Err.Number <> 0 Then            s.Name = Format(Now, "mm月dd日hhmmss")        End If        On Error GoTo 0                If r_end >= 2 Then            s.Rows(2 & ":" & r_end).Delete        End If                With s.Cells.Interior            .Pattern = xlNone            .TintAndShade = 0            .PatternTintAndShade = 0        End With            With s.Cells.Font            .ThemeColor = xlThemeColorLight1 '黒            .TintAndShade = 0        End With                With s.Cells.Font            .size = 12        End With                With s.Cells            .Borders(xlDiagonalDown).LineStyle = xlNone            .Borders(xlDiagonalUp).LineStyle = xlNone            .Borders(xlEdgeLeft).LineStyle = xlNone            .Borders(xlEdgeTop).LineStyle = xlNone            .Borders(xlEdgeBottom).LineStyle = xlNone            .Borders(xlEdgeRight).LineStyle = xlNone            .Borders(xlInsideVertical).LineStyle = xlNone            .Borders(xlInsideHorizontal).LineStyle = xlNone        End With                s.Cells(2, 1).Value = "層"        s.Cells(2, 2).Value = "ファイル名"        s.Cells(2, 3).Value = "種類"        s.Cells(2, 4).Value = "更新日"        s.Cells(2, 5).Value = "サイズ"        s.Cells(2, 6).Value = "ファイルパス"                i = 0        Call f_フォルダ情報取得(1, s.Cells(1, 1).Value)                Call f_配列ソート                s.Range(s.Cells(3, 1), s.Cells(i + 2, 6)).Value = WorksheetFunction.Transpose(table)                Set fso = Nothing                Cells.ColumnWidth = 2                With s.UsedRange            r_end = .Row + .Rows.Count - 1            c_end = .Column + .Columns.Count - 1        End With                s.Range(s.Cells(2, 1), s.Cells(r_end, c_end)).Select            ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = "テーブル1"        ActiveSheet.ListObjects("テーブル1").TableStyle = "TableStyleLight9"        ActiveSheet.ListObjects("テーブル1").ListColumns("更新日").DataBodyRange.NumberFormatLocal = "yyyy/mm/dd hh:mm;@"        ActiveSheet.ListObjects("テーブル1").ListColumns("サイズ").DataBodyRange.Style = "Comma [0]"            With Selection.Borders(xlInsideVertical)            .LineStyle = xlContinuous            .ThemeColor = xlThemeColorLight1 '黒            .TintAndShade = 0            .Weight = xlThin        End With            s.Rows("2:2").Select        With Selection            .HorizontalAlignment = xlLeft            .VerticalAlignment = xlTop            .WrapText = False                        If ActiveSheet.ListObjects("テーブル1").ListColumns.Count > 10 Then                .Orientation = xlVertical            End If                        .AddIndent = False            .IndentLevel = 0            .ShrinkToFit = False            .ReadingOrder = xlContext            .MergeCells = False        End With            s.Rows("3:3").Select        ActiveWindow.FreezePanes = False        ActiveWindow.FreezePanes = True                For i = 3 To r_end            If s.Cells(i, 3) = "ファイルフォルダー" Then                                With s.Range(s.Cells(i, 1), s.Cells(i, 6)).Interior                    .Pattern = xlSolid                    .PatternColorIndex = xlAutomatic                    .Color = 49407 '橙                    .TintAndShade = 0                    .PatternTintAndShade = 0                End With                            ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(i, 6), Address:=s.Cells(i, 6).Value, TextToDisplay:=s.Cells(i, 6).Value                        End If        Next i                s.Range(s.Cells(2, 1), s.Cells(r_end, c_end)).Select        Selection.ColumnWidth = 50        Selection.Columns.AutoFit        Selection.Rows.AutoFit                'テーブルソート' With ActiveWorkbook.ActiveSheet.ListObjects(1)' .Sort.SortFields.Clear' .Sort.SortFields.Add2 Key:=.ListColumns(3).Range, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal' .Sort.SortFields.Add2 Key:=.ListColumns(2).Range, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal' With .Sort' .Header = xlYes' .MatchCase = False' .Orientation = xlTopToBottom' .SortMethod = xlPinYin' .Apply' End With' End With                s.Range("A1").Select            End If        For i = r_start + 1 To r_start + i        If s.Cells(i, 3) <> "ファイルフォルダー" Then               If s.Cells(i, 4).Value > DateAdd("m", -6, Date) Then               s.Cells(i, 4).Interior.ColorIndex = 6 '黄               ElseIf s.Cells(i, 4).Value > DateAdd("y", -1, Date) Then               With s.Cells(i, 4).Interior                   .Pattern = xlSolid                   .PatternColorIndex = xlAutomatic                   .ThemeColor = xlThemeColorAccent4 '薄黄                   .TintAndShade = 0.8                   .PatternTintAndShade = 0               End With               ElseIf s.Cells(i, 4).Value > DateAdd("m", -18, Date) Then               With s.Cells(i, 4).Interior                   .Pattern = xlSolid                   .PatternColorIndex = xlAutomatic                   .ThemeColor = xlThemeColorAccent4 '薄黄                   .TintAndShade = 0.8                   .PatternTintAndShade = 0               End With               End If               If Left(s.Cells(i, 2).Value, 2) = "~$" Then               With s.Range(s.Cells(i, 2), s.Cells(i, 6)).Interior                   .Pattern = xlSolid                   .PatternColorIndex = xlAutomatic                   .ColorIndex = 15 '薄灰                   .TintAndShade = 0                   .PatternTintAndShade = 0               End With           End If                End If    Next i        On Error Resume Next    ActiveSheet.Hyperlinks.Add Anchor:=s.Cells(1, 1), Address:=s.Cells(1, 1).Value, TextToDisplay:=s.Cells(1, 1).Value    On Error GoTo 0        MsgBox "終了しました " & Int(Timer - w_timer) & "秒"    Application.StatusBar = False    End Sub
Function f_フォルダ情報取得(w_lebel As Integer, w_str As String) As Long
    Dim i_bk As Integer    Dim w_int As Integer        On Error Resume Next    Set pfl = fso.GetFolder(w_str) ' 親フォルダを取得    If Err.Number <> 0 Then        MsgBox "「EY Remote Connect」に接続されていない可能性があります。"        End    End If    On Error GoTo 0        Set fl = fso.GetFolder(w_str) ' フォルダを取得        For Each f In fl.Files ' フォルダ内のファイルを取得                i = i + 1                    Application.StatusBar = i & "件処理中"        DoEvents                ReDim Preserve table(1 To 6, 1 To i)                table(1, i) = "'" & w_lebel        table(2, i) = "'" & f.Name        table(3, i) = f.Type        table(4, i) = f.DateLastModified        table(5, i) = f.size        table(6, i) = ""            Next        For Each fl In pfl.SubFolders ' サブフォルダの一覧を取得                i = i + 1            Application.StatusBar = i & "件処理中"        DoEvents                ReDim Preserve table(1 To 6, 1 To i)                table(1, i) = "'" & w_lebel        table(2, i) = "'" & fl.Name        table(3, i) = fl.Type        table(4, i) = fl.DateLastModified        table(5, i) = ""        table(6, i) = fl.Path                '連続実行' If w_lebel >= 3 Then' Call f_フォルダ情報取得(w_lebel + 1, fl.Path)' End If        Next    End Function

ブック

Option Explicit
Dim fso As FileSystemObjectDim pfl As FolderDim fl As FolderDim f As FileDim s As WorksheetDim i As LongDim table() As Variant
Function f_配列ソート()
        Dim iNow '// ループカウンタ（現要素用）        Dim iBefore '// ループカウンタ（前要素用）        Dim temp1 '// 一時格納領域        Dim temp2 '// 一時格納領域        Dim temp3 '// 一時格納領域        Dim temp4 '// 一時格納領域        Dim temp5 '// 一時格納領域        Dim temp6 '// 一時格納領域        Dim iArrayCount '// 配列要素数
        '// 配列の要素数を取得        iArrayCount = UBound(table)
        '// 配列を２番目の要素から最後までループ        For iNow = 2 To i
            '// 配列の要素を一時格納            temp1 = table(1, iNow)            temp2 = table(2, iNow)            temp3 = table(3, iNow)            temp4 = table(4, iNow)            temp5 = table(5, iNow)            temp6 = table(6, iNow)
            '// 前要素を取得            iBefore = iNow - 1
            '// 前要素から先頭に向かってループ            Do                '// 配列要素外の場合                If (iBefore < 1) Then                    Exit Do                End If
                '// 入れ替える必要がない場合                If table(1, iBefore) <> temp1 Then                    Exit Do                ElseIf table(3, iBefore) <> "ファイルフォルダー" And temp3 = "ファイルフォルダー" Then                    Exit Do                ElseIf table(2, iBefore) <= temp2 Then                    Exit Do                End If
                '// 配列の前後を入れ替える                table(1, iBefore + 1) = table(1, iBefore)                table(2, iBefore + 1) = table(2, iBefore)                table(3, iBefore + 1) = table(3, iBefore)                table(4, iBefore + 1) = table(4, iBefore)                table(5, iBefore + 1) = table(5, iBefore)                table(6, iBefore + 1) = table(6, iBefore)
                '// 前要素を先頭側に移動する                iBefore = iBefore - 1
            Loop
            '// 挿入個所に事前に取得した値を格納            table(1, iBefore + 1) = temp1            table(2, iBefore + 1) = temp2            table(3, iBefore + 1) = temp3            table(4, iBefore + 1) = temp4            table(5, iBefore + 1) = temp5            table(6, iBefore + 1) = temp6
        Next        End Function
Sub ブック_連続実行()
    Dim w_timer As Single    Dim w_now As String        Columns(1).ClearContents    Cells(1, 1).Select        w_timer = Timer    w_now = Now    ActiveCell.Value = "'" & Now    Do Until Timer - w_timer > 1000        If Now <> w_now Then            SendKeys "{ENTER}"            DoEvents            DoEvents            ActiveCell.Value = "'" & Now & " (" & Int(Timer - w_timer) & ")"            w_now = Now                End If    Loop
End Sub

罫線

Option Explicit
Sub 罫線細中線() With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlHairline End With
End Sub

行

Option Explicit
Sub 行追加()
    Dim w_range As Range
    Set w_range = Selection
    Selection.EntireRow.Insert    Rows(Selection.Row).Select        With Selection.Interior        .Pattern = xlNone        .TintAndShade = 0        .PatternTintAndShade = 0    End With
    With Selection.Font        .ThemeColor = xlThemeColorLight1 '黒        .TintAndShade = 0        .size = 11    End With
    w_range.Select
End Sub
Sub グループ化()
    Dim r_end As Long    Dim c_end As Long    Dim w_active As Range    Dim i As Integer    Dim i1 As Integer    Dim s As Worksheet            Set s = ActiveSheet    Set w_active = ActiveCell            With s.UsedRange        r_end = .Row + .Rows.Count - 1        c_end = .Column + .Columns.Count - 1    End With        s.Cells.Select        On Error Resume Next    Selection.Rows.Ungroup    Selection.Rows.Ungroup    Selection.Rows.Ungroup    On Error GoTo 0        For i = 3 To r_end        If s.Cells(i, 1).Value <> "" And s.Cells(i, 1).Value = 2 And s.Cells(i + 1, 1).Value > 2 Then            For i1 = i + 1 To r_end + 1                If s.Cells(i1, 1).Value = "" Or s.Cells(i1, 1).Value <= 2 Then                    Exit For                End If            Next i1            s.Range(s.Rows(i + 1), s.Rows(i1 - 1)).Select            Selection.Rows.Group        End If    Next i        w_active.Select    End Sub

置換

Option Explicit
Sub 置換_まとめて()
    Dim s As Worksheet    Dim s0 As Worksheet    Dim w_listrow As ListRow    Dim w_str1 As String    Dim w_str2 As String    Dim w_str3 As String    Dim w_str4 As String    Dim w_str5 As String        Set s = ActiveSheet    Set s0 = ThisWorkbook.Sheets("置換")
    For Each w_listrow In s0.ListObjects(1).ListRows
        w_str1 = w_listrow.Range(1).Value        w_str2 = w_listrow.Range(2).Value
        If w_listrow.Range(4).Value = "レ" Then            w_str3 = "xlWhole"        Else            w_str3 = "xlPart"        End If
        If w_listrow.Range(3).Value = "レ" Then            w_str4 = "True"        Else            w_str4 = "False"        End If
        If w_listrow.Range(5).Value = "レ" Then            w_str5 = "True"        Else            w_str5 = "False"        End If
        Selection.Replace What:=w_str1, Replacement:=w_str2, LookAt:=w_str3, _            SearchOrder:=xlByRows, MatchCase:=w_str4, SearchFormat:=False, _            ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2, MatchByte:=w_str5            Next w_listrow
End Sub
Sub 置換_上の文字()        Dim w_str1 As String    Dim w_str2 As String        w_str1 = Selection(1).Offset(-1, 0).Value    w_str2 = Left(Selection(1).Value, Len(w_str1))        Selection.Replace What:=w_str2, Replacement:=w_str1, LookAt:=xlPart, _        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
End Sub
Sub 置換_◆()        Dim w_range As Range    Dim i As Integer    Dim w_str As String        With Selection        .IndentLevel = 0    End With        Selection.Replace What:="u ", Replacement:="◆", LookAt:=xlPart, _        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    For Each w_range In Selection.Cells                If Left(w_range.Text, 1) = "◆" Then            w_range.IndentLevel = 2        End If
        If Left(w_range.Text, 4) = "担当者：" Then            w_range.IndentLevel = 3        End If
        If Left(w_range.Text, 1) = "【" Then            w_range.IndentLevel = 3        End If
        If Left(Trim(w_range.Text), 1) = "→" Then            w_range.IndentLevel = 1        End If
        If Trim(w_range.Text) <> "" Then                    If Asc(Left(Trim(w_range.Text), 1)) = 63 Then                        w_str = ""                For i = 1 To Len(w_range.Text)                    If Asc(Mid(w_range.Text, i, 1)) = 63 Then                        w_str = w_str & "・"                        i = i + 1                    Else                        w_str = w_str & Mid(w_range.Text, i, 1)                    End If                Next i                w_range = w_str                    End If                End If                If Left(w_range.Text, 1) = "・" Then            w_range.IndentLevel = 2        End If        Next w_range
End Sub

貼付

Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function CloseClipboard Lib "user32" () As LongPrivate Declare Function EmptyClipboard Lib "user32" () As Long
Sub 自動貼り付け()
    Dim objCb As New DataObject        Dim w_timer As Single        w_timer = Timer
    Application.EnableCancelKey = xlErrorHandler    On Error GoTo MyError        i = 1    Do Until Timer - w_timer > 100
        Application.StatusBar = Int(Timer - w_timer) & "/100" & "秒"
        If Application.ClipboardFormats(1) <> -1 Then                        objCb.GetFromClipboard            ActiveCell = objCb.GetText                        OpenClipboard (0&)            EmptyClipboard            CloseClipboard                            ActiveCell.Offset(1, 0).Select                    End If
        DoEvents
    Loop
    Application.StatusBar = False    Exit Sub
MyError:
    If MsgBox("中断しますか？", vbQuestion + vbYesNo) = vbNo Then        Resume    Else        Application.StatusBar = False    End If
End Sub

列

Option Explicit
Sub 列_ファイルタイプ()
    'ファイルタイプを抽出しカレント列に編集する
    Dim s As Worksheet    Dim r_end As Long    Dim c_start As Integer    Dim i As Long    Dim w_int As Integer        Set s = ActiveSheet    With s.UsedRange        r_end = .Row + .Rows.Count - 1    End With    c_start = Selection.Column        If s.Cells(1, c_start).Value = "" Or Left(s.Cells(1, c_start).Value, 1) = "列" Then        s.Cells(1, c_start).Value = "種類"    End If        For i = 1 To r_end        If s.Cells(i, c_start).Value = "" Then            w_int = InStr(1, s.Cells(i, c_start - 1).Value, ".")            If w_int > 0 Then                s.Cells(i, c_start).Value = Mid(s.Cells(i, c_start - 1).Value, w_int, 99)            Else                s.Cells(i, c_start).Value = "'-"            End If        End If    Next i        Columns(c_start).AutoFit
End Sub
Sub 列_幅()
    '列幅を自動調整する        With Selection(1)            If .ColumnWidth = 2 Then            Selection.ColumnWidth = 1                ElseIf .ColumnWidth = 1 Then            Selection.ColumnWidth = 200                    ElseIf .ColumnWidth >= 200 Then            Selection.ColumnWidth = 100                    ElseIf .ColumnWidth >= 100 Then            Selection.ColumnWidth = 8.38                    Else            Selection.ColumnWidth = 2                    End If
    End With
End Sub

ツール

◆データ移行ツール_20231024版.xlsx

共有

Option Explicit
'「Microsoft ActiveX Data Objects X.X Library」を有効にする。
'Windows認証で接続する場合Public Const PROVIDER As String = "SQLOLEDB"Public DATA_SOURCE As String 'サーバ名Public DATABASE As String 'データベース名
'SQL Server認証で接続する場合Public Const USER_ID As String = "UID=user" 'ユーザIDPublic Const PASSWORD As String = "password" 'ユーザパスワード
Public cn As New ADODB.ConnectionPublic rs As New ADODB.Recordset
Public myDic1 As ObjectPublic myDic2 As ObjectPublic myDic3 As ObjectPublic myDicCOL As Object
Public b As WorkbookPublic b1 As Workbook
Public s As WorksheetPublic i As LongPublic j As LongPublic x As Integer
Public s1 As WorksheetPublic r1_start As LongPublic r1_end As LongPublic c1_start As LongPublic c1_end As LongPublic i1 As LongPublic j1 As Long
Public s2 As WorksheetPublic r2_start As LongPublic r2_end As LongPublic c2_start As LongPublic c2_end As LongPublic c2_end_tbl As LongPublic i2 As LongPublic j2 As Long
Public s3 As WorksheetPublic s4 As Worksheet
Public FileNumberPublic nm As NamePublic strSQL As String
Public w_proc As StringPublic w_range As RangePublic w_sql As StringPublic w_str As StringPublic w_str1 As StringPublic w_str2 As StringPublic w_ret As IntegerPublic w_err As BooleanPublic w_long As LongPublic w_sheet As Worksheet
Public w_ファイル名 As StringPublic w_ブック名 As StringPublic w_フルパス As StringPublic w_サービスコード As StringPublic w_区コード As StringPublic w_新個人番号 As IntegerPublic w_利用者番号 As IntegerPublic w_事業者コード As IntegerPublic w_品名コード As IntegerPublic w_ログファイル名 As StringPublic w_エラー内容 As String
Public w_テーブル名(1 To 10) As String
Public r1_項目名行 As LongPublic r2_項目名行 As Long
Public c_sql As Integer
Public MyArray As Variant
Public w_step As Integer
Function f_A1選択()        'A1を選択する。        ActiveWindow.LargeScroll ToLeft:=99    ActiveWindow.LargeScroll Up:=99    ActiveSheet.Range("A1").Select        End Function
Function f_年月日変換(p_str As Variant) As String
    '年月日変換
    Dim w1 As String    Dim w2 As String    Dim w3 As Variant
    w1 = Mid(p_str, 1, 1)    w2 = Mid(p_str, 2, 9)    w3 = Split(w2, ".")
    Select Case Left(s2.Cells(i2, myDicCOL("生年月日（西暦）")).Value, 1)            Case "S", "s"            w3(0) = w3(0) + 1925            Case "H", "h"            w3(0) = w3(0) + 1988            Case "R", "r"            w3(0) = w3(0) + 2018        End Select        On Error Resume Next    f_年月日変換 = Format(w3(0), "0000") & Format(w3(1), "00") & Format(w3(2), "00")    If Err.Number <> 0 Then        MsgBox "年月日変換エラー（" & p_str & "）"        f_結果NG        Exit Function    End If    On Error GoTo 0
End Function
Function f_事業者コード検索(p_str As Variant) As Boolean
    '事業者コード検索        Dim myRange As Range    Dim myObj As Range        f_事業者コード検索 = False        Set myRange = s3.Columns(4)    Set myObj = myRange.Find(p_str, LookAt:=xlPart)        If myObj Is Nothing Then        s2.Cells(i2, myDicCOL("事業者コード／名称")).Interior.ColorIndex = 6 '黄色        Exit Function    End If        w_事業者コード = s3.Cells(myObj.Row, 2).Value
    f_事業者コード検索 = True
End Function
Function f_品名コード検索(p_str As Variant, p_col As Integer) As Boolean
    '品名コード検索        Dim myRange As Range    Dim myObj As Range        f_品名コード検索 = False        Set myRange = s4.Columns(5)    Set myObj = myRange.Find(p_str, LookAt:=xlPart)        If myObj Is Nothing Then        s2.Cells(i2, p_col).Interior.ColorIndex = 6 '黄色        Exit Function    End If        w_品名コード = s4.Cells(myObj.Row, 2).Value
    f_品名コード検索 = True
End Function
Function f_項目名行検索(p_sheet As Worksheet) As Integer
    '事業者コード検索        f_項目名行検索 = 0
    On Error Resume Next    p_sheet.Columns("B:B").Select    Set w_range = Selection.Find(What:="項目名", After:=ActiveCell, LookIn:=xlFormulas, _        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _        MatchCase:=False, MatchByte:=False, SearchFormat:=False)    If w_range.Value = "" Then        MsgBox "「項目名」の行を特定出来ませんでした。"        f_結果NG        Exit Function    End If    On Error GoTo 0        f_項目名行検索 = w_range.Row
End Function
Function f_データベース切断()
    '--------------------------------    ' データベース切断    '--------------------------------    If Not rs Is Nothing Then        If rs.State = adStateOpen Then rs.Close        Set rs = Nothing    End If    If Not cn Is Nothing Then        If cn.State = adStateOpen Then cn.Close        Set cn = Nothing    End If
End Function
Function f_データベース接続() As Boolean
    '--------------------------------    ' データベース接続    '--------------------------------    f_データベース接続 = False    On Error Resume Next        'Windows認証で接続する場合    cn.ConnectionString = "Provider=" & PROVIDER _                        & ";Data Source=" & DATA_SOURCE _                        & ";Initial Catalog=" & DATABASE _                        & ";Trusted_Connection=Yes"    cn.Open
' 'SQL Server認証で接続する場合' cn.ConnectionString = "Provider=" & PROVIDER _' & ";Data Source=" & DATA_SOURCE _' & ";Initial Catalog=" & DATABASE _' & ";UID=" & USER_ID _' & ";PWD=" & PASSWORD' cn.Open
    If Err.Number <> 0 Then        Exit Function    End If
    On Error GoTo 0    f_データベース接続 = True
End Function
Function f_サーバー情報設定()
    'サーバー情報設定
    DATA_SOURCE = s.Range("_サーバー名").Value    DATABASE = s.Range("_データベース名")(s.Range("_データベース名_選択").Value)
End Function
Function f_結果NG()
    '結果エラー
    Select Case w_proc        Case "2"            If w_エラー内容 <> "" Then                s.Range("_②").Value = "NG⇒" & w_エラー内容            Else                s.Range("_②").Value = "NG"            End If            s.Range("_②").Interior.ColorIndex = 6 '黄色        Case "3"            If w_ログファイル名 = "" Then                s.Range("_③").Value = "NG"            Else                s.Range("_③").Value = "NG⇒「" & w_ログファイル名 & "」参照。"            End If            s.Range("_③").Interior.ColorIndex = 6 '黄色        Case "4"            If w_エラー内容 <> "" Then                s.Range("_④").Value = "NG⇒" & w_エラー内容            Else                s.Range("_④").Value = "NG"            End If            s.Range("_④").Interior.ColorIndex = 6 '黄色        Case "5"            s.Range("_⑤").Value = "NG⇒「" & w_ログファイル名 & "」参照。"            s.Range("_⑤").Interior.ColorIndex = 6 '黄色        Case "A2"            s.Range("_A②").Value = "NG"            s.Range("_A②").Interior.ColorIndex = 6 '黄色        Case "A3"            s.Range("_A③").Value = "NG⇒「" & w_ログファイル名 & "」参照。"            s.Range("_A③").Interior.ColorIndex = 6 '黄色        Case "A4"            s.Range("_A④").Value = "NG⇒「" & w_ログファイル名 & "」参照。"            s.Range("_A④").Interior.ColorIndex = 6 '黄色        Case "B2"            s.Range("_B②").Value = "NG"            s.Range("_B②").Interior.ColorIndex = 6 '黄色        Case "B3"            s.Range("_B③").Value = "NG⇒「" & w_ログファイル名 & "」参照。"            s.Range("_B③").Interior.ColorIndex = 6 '黄色        Case "B4"            s.Range("_B④").Value = "NG⇒「" & w_ログファイル名 & "」参照。"            s.Range("_B④").Interior.ColorIndex = 6 '黄色        Case "X2"            s.Range("_X②").Value = "NG"            s.Range("_X②").Interior.ColorIndex = 6 '黄色    End Select        s.Activate
End Function
Function f_結果OK()
    Select Case w_proc        Case "2"            s.Range("_②").Value = "OK⇒シート「" & b1.Sheets(2).Name & "」にバックアップしました。"        Case "3"            s.Range("_③").Value = "OK⇒キー項目を編集しました。「" & w_ログファイル名 & "」参照。"        Case "4"            s.Range("_④").Value = "OK⇒変換しました。"        Case "5"            s.Range("_⑤").Value = "OK⇒「" & w_ログファイル名 & "」参照。"        Case "A2"            s.Range("_A②").Value = "OK⇒青色のセルを編集しました。"        Case "A3"            s.Range("_A③").Value = "OK⇒「" & w_ログファイル名 & "」参照。"        Case "A4"            s.Range("_A④").Value = "OK⇒「" & w_ログファイル名 & "」参照。"        Case "B2"            s.Range("_B②").Value = "OK⇒青色のセルを編集しました。"        Case "B3"            s.Range("_B③").Value = "OK⇒「" & w_ログファイル名 & "」参照。"        Case "B4"            s.Range("_B④").Value = "OK⇒「" & w_ログファイル名 & "」参照。"        Case "X2"            s.Range("_X②").Value = "OK⇒個人情報項目を編集しました。"    End Select
    s.Activate    MsgBox "正常終了しました。"
End Function
Function f_事業者マスタ設定() As Boolean
    '事業者マスタ設定
    f_事業者マスタ設定 = False        On Error Resume Next    s.Activate    For Each w_sheet In ThisWorkbook.Sheets        If InStr(1, w_sheet.Name, "事業者マスタ") > 0 Then            Set s3 = w_sheet            Exit For        End If    Next w_sheet    On Error GoTo 0        If s3 Is Nothing Then        MsgBox "事業者マスタのシートがありません。"        f_結果NG        Exit Function    End If        f_事業者マスタ設定 = True
End Function
Function f_共有マスタ設定() As Boolean
    '品名マスタ設定
    f_共有マスタ設定 = False        On Error Resume Next    s.Activate    For Each w_sheet In ThisWorkbook.Sheets        If InStr(1, w_sheet.Name, "共有マスタ") > 0 Then            Set s4 = w_sheet            Exit For        End If    Next w_sheet    On Error GoTo 0        If s4 Is Nothing Then        MsgBox "共有マスタのシートがありません。"        f_結果NG        Exit Function    End If        f_共有マスタ設定 = True
End Function
Function f_各区入力様式シート設定() As Boolean
    '各区入力様式シート設定
    f_各区入力様式シート設定 = False        '■ フルパス、ファイル名    Select Case w_proc        Case "1", "2", "3", "4", "5"            w_フルパス = s.Range("_①").Value        Case "A1", "A2", "A3", "A4"            w_フルパス = s.Range("_A①").Value        Case "B1", "B2", "B3", "B4"            w_フルパス = s.Range("_B①").Value        Case "X1", "X2"            w_フルパス = s.Range("_X①").Value    End Select    w_ファイル名 = Mid(w_フルパス, InStrRev(w_フルパス, "\") + 1, 999)        '■ ブック名    If w_ファイル名 <> "" Then        w_ブック名 = Left(w_ファイル名, InStrRev(w_ファイル名, ".") - 1)    End If        '■ ①対象「各区入力様式」ファイルが開けません    On Error Resume Next    Err.Clear    Workbooks(w_ファイル名).Activate    If Err.Number <> 0 Then        Err.Clear        Workbooks.Open (w_フルパス)        If Err.Number <> 0 Then            MsgBox "①対象「各区入力様式」ファイルが開けません。"            f_結果NG            Exit Function        End If    End If    On Error GoTo 0
    '■ 使用範囲設定    Sheets(1).Activate    Set b1 = ActiveWorkbook    Set s2 = ActiveSheet    With s2.UsedRange        r2_start = .Row        r2_end = .Row + .Rows.Count - 1        c2_start = .Column        c2_end = .Column + .Columns.Count - 1    End With        '■ 項目名行検索    r2_項目名行 = f_項目名行検索(s2)    If r2_項目名行 = 0 Then        Exit Function    End If
    '■ Dictionaryオブジェクトの宣言    Set myDicCOL = CreateObject("Scripting.Dictionary")        '■ 項目名配列作成    s2.Activate    For j2 = 3 To c2_end        If s2.Cells(r2_項目名行, j2).Value <> "" Then            myDicCOL.Add s2.Cells(r2_項目名行, j2).Value, s2.Cells(r2_項目名行, j2).Column        End If    Next j2        '■コピーチェック    If w_proc <> "1" And w_proc <> "2" And w_proc <> "A1" And w_proc <> "B1" And w_proc <> "X1" And w_proc <> "X2" Then        If Not myDicCOL.exists("決定サービス別") Then            MsgBox "データ移行「②項目名確認、シートバックアップ」から実行してください。"            f_結果NG            Exit Function        End If    End If        '■ 結果列    For j2 = 2 To c2_end        If s2.Cells(r2_項目名行, j2).Value = "" Or s2.Cells(1, j2).Value = "追加" Then            Exit For        End If    Next j2    c2_end_tbl = j2 - 1        f_各区入力様式シート設定 = True
End Function
Function f_ひな型シート設定() As Boolean
    f_ひな型シート設定 = False
    '■ ひな型シート    b.Activate    Select Case s2.Cells(r2_項目名行 + 1, 3).Value        Case "02", 2            SheetB02.Select        Case "03", 3            SheetB03.Select        Case "04", 4            SheetB04.Select        Case "06", 6            SheetB06.Select        Case "07", 7            SheetB07.Select        Case "08", 8            SheetB08.Select        Case "09", 9            SheetB09.Select        Case "10", 10            SheetB10.Select        Case Else            MsgBox "各区入力様式のひな型シートがありません。"            s.Activate            Exit Function    End Select        If Err.Number <> 0 Then        MsgBox "各区入力様式のひな型シートがありません。"        s.Activate        Exit Function    End If        '■ 使用範囲設定    Set s1 = ActiveSheet    With s1.UsedRange        r1_start = .Row        r1_end = .Row + .Rows.Count - 1        c1_start = .Column        c1_end = .Column + .Columns.Count - 1    End With
    '■ 項目名行検索    r1_項目名行 = f_項目名行検索(s1)    If r1_項目名行 = 0 Then        Exit Function    End If
    f_ひな型シート設定 = True
End Function
Function f_実行シート設定() As Boolean
    '実行シート設定
    f_実行シート設定 = False        Set b = ActiveWorkbook    Set s = ActiveSheet
    '■ 結果欄クリア    s.Range("_①").Interior.ColorIndex = 20 '薄青色    s.Range("_A①").Interior.ColorIndex = 35 '薄緑色    s.Range("_B①").Interior.ColorIndex = 35 '薄緑色    Select Case w_proc        Case "1", "2", "X1"            s.Range("_②").Value = ""            s.Range("_②").Interior.ColorIndex = 20 '薄青色    End Select        Select Case w_proc        Case "1", "2", "3", "X1"            s.Range("_③").Value = ""            s.Range("_③").Interior.ColorIndex = 20 '薄青色    End Select        Select Case w_proc        Case "1", "2", "3", "4", "X1"            s.Range("_④").Value = ""            s.Range("_④").Interior.ColorIndex = 20 '薄青色    End Select        Select Case w_proc        Case "1", "2", "3", "4", "5", "X1"            s.Range("_⑤").Value = ""            s.Range("_⑤").Interior.ColorIndex = 20 '薄青色    End Select        Select Case w_proc        Case "A1", "A2", "1", "2", "3", "4", "5"            s.Range("_A②").Value = ""            s.Range("_A②").Interior.ColorIndex = 35 '薄緑色    End Select        Select Case w_proc        Case "A1", "A2", "A3", "1", "2", "3", "4", "5"            s.Range("_A③").Value = ""            s.Range("_A③").Interior.ColorIndex = 35 '薄緑色    End Select        Select Case w_proc        Case "A1", "A2", "A3", "A4", "1", "2", "3", "4", "5"            s.Range("_A④").Value = ""            s.Range("_A④").Interior.ColorIndex = 35 '薄緑色    End Select        Select Case w_proc        Case "B1", "B2", "1", "2", "3", "4", "5"            s.Range("_B②").Value = ""            s.Range("_B②").Interior.ColorIndex = 35 '薄緑色    End Select        Select Case w_proc        Case "B1", "B2", "B3", "1", "2", "3", "4", "5"            s.Range("_B③").Value = ""            s.Range("_B③").Interior.ColorIndex = 35 '薄緑色    End Select        Select Case w_proc        Case "B1", "B2", "B3", "B4", "1", "2", "3", "4", "5"            s.Range("_B④").Value = ""            s.Range("_B④").Interior.ColorIndex = 35 '薄緑色    End Select        Select Case w_proc        Case "X1", "X2"            s.Range("_X②").Value = ""            s.Range("_X②").Interior.ColorIndex = 15 '薄灰色    End Select        '■ ①対象「各区入力様式」ファイルを指定    If w_proc <> "1" And w_proc <> "A1" And w_proc <> "B1" And w_proc <> "X1" Then            If w_proc = "1" Then            If s.Range("_①").Value = "" Then                MsgBox "①対象「各区入力様式」ファイルを指定してください。"                Exit Function            End If        End If                If w_proc = "A1" Then            If s.Range("_A①").Value = "" Then                MsgBox "①対象「各区入力様式」ファイルを指定してください。"                Exit Function            End If        End If
        If w_proc = "B1" Then            If s.Range("_B①").Value = "" Then                MsgBox "①対象「各区入力様式」ファイルを指定してください。"                Exit Function            End If        End If
        If w_proc = "X1" Then            If s.Range("_X①").Value = "" Then                MsgBox "①対象「各区入力様式」ファイルを指定してください。"                Exit Function            End If        End If
    End If
    '■ 前実行結果    Select Case w_proc        Case "3"            If Left(s.Range("_②").Value, 2) <> "OK" Then                MsgBox "②を実行して、OKにしてください。"                Exit Function            End If        Case "4"            If Left(s.Range("_③").Value, 2) <> "OK" Then                MsgBox "③を実行して、OKにしてください。"                Exit Function            End If        Case "5"            If Left(s.Range("_④").Value, 2) <> "OK" Then                MsgBox "④を実行して、OKにしてください。"                Exit Function            End If        Case "6"            If Left(s.Range("_⑤").Value, 2) <> "OK" Then                MsgBox "⑤を実行して、OKにしてください。"                Exit Function            End If        Case "A3"            If Left(s.Range("_A②").Value, 2) <> "OK" Then                MsgBox "②を実行して、OKにしてください。"                Exit Function            End If        Case "A4"            If Left(s.Range("_A③").Value, 2) <> "OK" Then                MsgBox "③を実行して、OKにしてください。"                Exit Function            End If        Case "B3"            If Left(s.Range("_B②").Value, 2) <> "OK" Then                MsgBox "②を実行して、OKにしてください。"                Exit Function            End If        Case "B4"            If Left(s.Range("_B③").Value, 2) <> "OK" Then                MsgBox "③を実行して、OKにしてください。"                Exit Function            End If    End Select        f_実行シート設定 = True
End Function

①

Option Explicit Sub ①_Click() '対象「各区入力様式」ファイル指定 w_proc = "1" '■ ファイル選択（s） w_step = 1 Application.StatusBar = "【" & w_step & "】ファイル選択": w_step = w_step + 1 Set s = ActiveSheet With Application.FileDialog(msoFileDialogFilePicker) .Title = "ファイルを選択してください。" .Filters.Clear .Filters.Add "エクセルファイル", "*.xlsx" .FilterIndex = 1 .AllowMultiSelect = False .InitialFileName = ActiveWorkbook.Path & "\" w_ret = .Show If w_ret <> 0 Then s.Range("_①").Value = .SelectedItems.Item(1) s.Range("_①").Columns.AutoFit s.Range("_A①").Value = .SelectedItems.Item(1) s.Range("_B①").Value = .SelectedItems.Item(1) s.Range("_X①").Value = .SelectedItems.Item(1) '■ 実行シート設定（s） If f_実行シート設定 = False Then MsgBox "実行シート設定" & "　エラー" Exit Sub End If '■ 各区入力様式シート設定（s2） If f_各区入力様式シート設定 = False Then MsgBox "各区入力様式シート設定" & "　エラー" Exit Sub End If s.Activate Else MsgBox "キャンセルされました。" End If End With
Application.StatusBar = False
End Sub

②

Option Explicit
Sub ②_Click()
'項目名確認、シートバックアップ w_proc = "2" '■ 実行シート設定（s） w_step = 1 Application.StatusBar = "【" & w_step & "】実行シート設定": w_step = w_step + 1 If f_実行シート設定 = False Then MsgBox "実行シート設定" & "　エラー" Exit Sub End If '■ 各区入力様式シート設定（s2） Application.StatusBar = "【" & w_step & "】各区入力様式シート設定": w_step = w_step + 1 If f_各区入力様式シート設定 = False Then MsgBox "各区入力様式シート設定" & "　エラー" Exit Sub End If '■ ひな型シート設定（s1） Application.StatusBar = "【" & w_step & "】ひな型シート設定": w_step = w_step + 1 If f_ひな型シート設定 = False Then MsgBox "ひな型シート設定" & "　エラー" Exit Sub End If '■ 項目名置換（s2） Application.StatusBar = "【" & w_step & "】項目名置換": w_step = w_step + 1 'サービス配達先 s2.Rows(r2_項目名行).Replace What:="新個人番号", Replacement:="利用者番号", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False '■ 項目比較（s2） Application.StatusBar = "【" & w_step & "】項目比較": w_step = w_step + 1 s2.Activate For j = 3 To c2_end_tbl If s2.Cells(r2_項目名行, j).Value = "" Then Exit For End If If s1.Cells(r1_項目名行, j).Value <> s2.Cells(r2_項目名行, j).Value Then s2.Activate s2.Cells(r2_項目名行, j).Select w_エラー内容 = "項目不一致あり。" & vbCrLf & "「" & s1.Cells(r1_項目名行, j).Value & "」≠「" & s2.Cells(r2_項目名行, j).Value & "」" MsgBox w_エラー内容 f_結果NG Exit Sub End If Next j '■ 名前削除（s2） Application.StatusBar = "【" & w_step & "】名前削除": w_step = w_step + 1 s2.Activate On Error Resume Next Application.ScreenUpdating = False For Each nm In ActiveWorkbook.Names nm.Delete Next Application.ScreenUpdating = True On Error GoTo 0 '■ シートバックアップ（s2） Application.StatusBar = "【" & w_step & "】シートバックアップ": w_step = w_step + 1 s2.Activate w_long = InStr(1, s2.Name, " ") If w_long > 0 Then w_str = Left(s2.Name, w_long - 1) Else w_str = s2.Name End If s2.Copy After:=s2 ActiveSheet.Name = w_str & " BK" & Format(Now, "yyyymmdd_hhmmss") s2.Activate s2.Name = w_str '■ 全行表示（s2） Application.StatusBar = "【" & w_step & "】全行表示": w_step = w_step + 1 s2.Activate On Error Resume Next s2.ShowAllData On Error GoTo 0 '■ 不要列削除（s2） Application.StatusBar = "【" & w_step & "】不要列削除": w_step = w_step + 1 s2.Activate If c2_end_tbl + 1 < c2_end Then s2.Activate s2.Range(s2.Columns(c2_end_tbl + 1), s2.Columns(c2_end)).Delete End If '■ 項目情報コピー（s2） Application.StatusBar = "【" & w_step & "】項目情報コピー": w_step = w_step + 1 s1.Activate s1.Rows(r1_項目名行 - 2 & ":" & r1_項目名行).Select Selection.Copy s2.Activate s2.Rows(r2_項目名行 - 2 & ":" & r2_項目名行).Select ActiveSheet.Paste Application.CutCopyMode = False '■ テーブル情報張り替え（s2） Application.StatusBar = "【" & w_step & "】テーブル情報張り替え": w_step = w_step + 1 s2.Activate If 1 < r2_項目名行 - 3 Then s2.Rows("1:" & r2_項目名行 - 3).Select Selection.Delete End If s1.Activate If 1 < r1_項目名行 - 3 Then s1.Rows("1:" & r1_項目名行 - 3).Select Selection.Copy s2.Activate s2.Rows(1).Select Selection.Insert Shift:=xlDown End If r2_end = r2_end + r1_項目名行 - r2_項目名行 - 1 r2_項目名行 = r1_項目名行 '■ 連番編集（s2） Application.StatusBar = "【" & w_step & "】連番編集": w_step = w_step + 1 s2.Activate s2.Cells(r2_項目名行 + 1, 2).Value = "=ROW()-" & r2_項目名行 '■ 左詰め（s2） Application.StatusBar = "【" & w_step & "】左詰め": w_step = w_step + 1 With s2.UsedRange r2_end = .Row + .Rows.Count - 1 c2_end = .Column + .Columns.Count - 1 End With s2.Range(s2.Cells(r2_項目名行 + 1, 3), s2.Cells(r2_end, c2_end)).HorizontalAlignment = xlLeft '■ 範囲に変換（s2） Application.StatusBar = "【" & w_step & "】範囲に変換": w_step = w_step + 1 On Error Resume Next ActiveSheet.ListObjects(1).TableStyle = "TableStyleLight9" s2.ListObjects(1).Unlist On Error GoTo 0 '■ フィルター（s2） Application.StatusBar = "【" & w_step & "】フィルター": w_step = w_step + 1 s2.Rows(r2_項目名行).AutoFilter '■ A1選択（s2） Application.StatusBar = "【" & w_step & "】A1選択": w_step = w_step + 1 s2.Activate f_A1選択 '■ 結果（s） Application.StatusBar = "【" & w_step & "】結果": w_step = w_step + 1 s.Activate f_結果OK Application.StatusBar = False
End Sub

③

Option Explicit
Sub ③_Click()
    'キー項目チェック    w_proc = "3"
    '■ 実行シート設定（s）    w_step = 1    Application.StatusBar = "【" & w_step & "】実行シート設定": w_step = w_step + 1    If f_実行シート設定 = False Then        MsgBox "実行シート設定" & "　エラー"        Exit Sub    End If        '■ 各区入力様式シート設定（s2）    Application.StatusBar = "【" & w_step & "】各区入力様式シート設定": w_step = w_step + 1    If f_各区入力様式シート設定 = False Then        MsgBox "各区入力様式シート設定" & "　エラー"        Exit Sub    End If        '■ 利用者番号と連番をクリア（s2）    Application.StatusBar = "【" & w_step & "】利用者番号と連番をクリア": w_step = w_step + 1    s2.Activate    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("利用者番号")), s2.Cells(r2_end, myDicCOL("利用者番号"))).ClearContents    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("利用者番号")), s2.Cells(r2_end, myDicCOL("利用者番号"))).Interior.ColorIndex = 16 '濃灰色    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("連番")), s2.Cells(r2_end, myDicCOL("連番"))).ClearContents    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("連番")), s2.Cells(r2_end, myDicCOL("連番"))).Interior.ColorIndex = 16 '濃灰色    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("利用者番号2")), s2.Cells(r2_end, myDicCOL("利用者番号2"))).ClearContents    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("利用者番号2")), s2.Cells(r2_end, myDicCOL("利用者番号2"))).Interior.ColorIndex = xlNone        '■ キー項目チェック（s2）    Application.StatusBar = "【" & w_step & "】キー項目チェック": w_step = w_step + 1    s2.Activate    On Error Resume Next    For i2 = r2_項目名行 + 1 To r2_end                If Not (s2.Cells(i2, 3).Value = "" And s2.Cells(i2, 4).Value = "" And s2.Cells(i2, 5).Value = "" _            And s2.Cells(i2, 17).Value = "" And s2.Cells(i2, 18).Value = "") Then            If Not (s2.Cells(i2, 3).Value <> "" And s2.Cells(i2, 4).Value <> "" And s2.Cells(i2, 5).Value <> "" _                And s2.Cells(i2, 17).Value <> "" And s2.Cells(i2, 18).Value <> "") Then                                w_err = False                                '----------------------------------------------------------------------------------------                'サービスコード                x = myDicCOL("サービスコード")                If s2.Cells(i2, x).Value = "" Or Len(s2.Cells(i2, x).Value) > 2 Or IsNumeric(s2.Cells(i2, x).Value) = False Then                    s2.Cells(i2, x).Interior.ColorIndex = 6 '黄色                    w_err = True                Else                    w_サービスコード = Format(s2.Cells(i2, x).Value, "00")                End If                                '----------------------------------------------------------------------------------------                '区コード                x = myDicCOL("区コード")                If s2.Cells(i2, x).Value = "" Or Len(s2.Cells(i2, x).Value) > 2 Or IsNumeric(s2.Cells(i2, x).Value) = False Then                    s2.Cells(i2, x).Interior.ColorIndex = 6 '黄色                    w_err = True                Else                    w_区コード = Format(s2.Cells(i2, x).Value, "00")                End If                                '----------------------------------------------------------------------------------------                'カナ氏名（半角）                x = myDicCOL("カナ氏名（半角）")                If s2.Cells(i2, x).Value = "" Then                    s2.Cells(i2, x).Interior.ColorIndex = 6 '黄色                    w_err = True                End If                                '----------------------------------------------------------------------------------------                '生年月日（西暦）                x = myDicCOL("生年月日（西暦）")                If s2.Cells(i2, x).Value = "" Then                    s2.Cells(i2, x).Interior.ColorIndex = 6 '黄色                    w_err = True                End If                            End If        End If    Next i2    On Error GoTo 0        '■ エラーチェック（s）    Application.StatusBar = "【" & w_step & "】エラーチェック": w_step = w_step + 1    s.Activate    If w_err Then        s2.Activate        MsgBox "各区入力様式のキー項目にエラーがあります。（黄色セル）"        f_結果NG        Exit Sub    End If
    '■ 配列にコピー（s2）    Application.StatusBar = "【" & w_step & "】配列にコピー": w_step = w_step + 1    s2.Activate    MyArray = s2.Range(s2.Cells(1, 1), s2.Cells(r2_end, c2_end))    Debug.Print "========================================================================="    Debug.Print LBound(MyArray, 1) & "-" & UBound(MyArray, 1)    Debug.Print LBound(MyArray, 2) & "-" & UBound(MyArray, 2)    Debug.Print "========================================================================="    ReDim MyArray2(1 To UBound(MyArray, 1), 1 To UBound(MyArray, 2))        '■ Dictionaryオブジェクトの宣言    Application.StatusBar = "【" & w_step & "】Dictionaryオブジェクトの宣言": w_step = w_step + 1    Set myDic1 = CreateObject("Scripting.Dictionary")        '■ 「利用者番号（新個人番号）」設定（s2）    Application.StatusBar = "【" & w_step & "】「利用者番号（新個人番号）」設定": w_step = w_step + 1    w_新個人番号 = 1    For i2 = r2_項目名行 + 1 To r2_end            If MyArray(i2, myDicCOL("サービスコード")) = MyArray(r2_項目名行 + 1, myDicCOL("サービスコード")) _            And MyArray(i2, myDicCOL("区コード")) = MyArray(r2_項目名行 + 1, myDicCOL("区コード")) _            And (MyArray(i2, myDicCOL("カナ氏名（半角）")) <> "" Or MyArray(i2, myDicCOL("生年月日（西暦）")) <> "") Then            w_str = MyArray(i2, myDicCOL("カナ氏名（半角）")) & "-" & MyArray(i2, myDicCOL("生年月日（西暦）"))            If myDic1.exists(w_str) Then                MyArray(i2, myDicCOL("利用者番号")) = myDic1(w_str)            Else                MyArray(i2, myDicCOL("利用者番号")) = "RYS" & w_サービスコード & w_区コード & Format(w_新個人番号, "00000000")                myDic1.Add w_str, MyArray(i2, myDicCOL("利用者番号"))                w_新個人番号 = w_新個人番号 + 1            End If        End If            Next i2        '■ Dictionaryオブジェクトの宣言    Application.StatusBar = "【" & w_step & "】Dictionaryオブジェクトの宣言": w_step = w_step + 1    Set myDic2 = CreateObject("Scripting.Dictionary")        '■ 「連番」設定（s2）    Application.StatusBar = "【" & w_step & "】「連番」設定": w_step = w_step + 1    For i2 = r2_項目名行 + 1 To r2_end        If MyArray(i2, myDicCOL("利用者番号")) <> "" And MyArray(i2, myDicCOL("連番")) = "" Then                    w_str = MyArray(i2, myDicCOL("利用者番号"))            If myDic2.exists(w_str) Then                MyArray(i2, myDicCOL("連番")) = Format(myDic2(w_str) + 1, "00")                myDic2.Remove w_str                myDic2.Add w_str, MyArray(i2, myDicCOL("連番"))            Else                MyArray(i2, myDicCOL("連番")) = "01"                myDic2.Add w_str, MyArray(i2, myDicCOL("連番"))            End If                    End If    Next i2        '■ サーバー情報設定    Application.StatusBar = "【" & w_step & "】サーバー情報設定": w_step = w_step + 1    f_サーバー情報設定        '■ データベース接続    Application.StatusBar = "【" & w_step & "】データベース接続": w_step = w_step + 1    If f_データベース接続 = False Then        MsgBox "データベース接続　エラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description        Exit Sub    End If        '■ ログファイルオープン    Application.StatusBar = "【" & w_step & "】ログファイルオープン": w_step = w_step + 1    FileNumber = FreeFile    Close #FileNumber    w_ログファイル名 = w_ブック名 & "_LOG③.txt"    Open ThisWorkbook.Path & "\" & w_ログファイル名 For Output As #FileNumber        '■ Select（s2）    Application.StatusBar = "【" & w_step & "】Select": w_step = w_step + 1    s2.Activate    strSQL = "SELECT MAX(SUBSTRING([DC_RIYONO],4,4)) AS RIYONO" & vbCrLf _            & " FROM D_Common" & vbCrLf _            & " WHERE [DC_KUCD] = " & MyArray(r2_項目名行 + 1, myDicCOL("区コード"))
    '■ ログファイル出力    Application.StatusBar = "【" & w_step & "】ログファイル出力": w_step = w_step + 1    Print #FileNumber, "--------------------------------------------------"    Print #FileNumber, strSQL
    '■ SQLの実行    Application.StatusBar = "【" & w_step & "】SQLの実行": w_step = w_step + 1    On Error Resume Next    rs.Open strSQL, cn    If Err.Number <> 0 Then
        '■ ログファイル出力        Print #FileNumber, "--------------------------------------------------"        Print #FileNumber, "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description
        '■ ログファイルクローズ        Close #FileNumber
        '■ データベース切断        f_データベース切断
        MsgBox "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description        f_結果NG        Exit Sub
    Else            '■ ログファイル出力        Print #FileNumber, "--------------------------------------------------"        Print #FileNumber, "⇒RIYONO=" & rs![RIYONO]                If IsNumeric(rs![RIYONO]) Then            w_利用者番号 = rs![RIYONO] + 1        Else            w_利用者番号 = 1        End If
    End If    On Error GoTo 0        '■ Dictionaryオブジェクトの宣言    Application.StatusBar = "【" & w_step & "】Dictionaryオブジェクトの宣言": w_step = w_step + 1    Set myDic3 = CreateObject("Scripting.Dictionary")        '■ 「利用者番号２」配列作成（s2）    Application.StatusBar = "【" & w_step & "】「利用者番号２」配列作成": w_step = w_step + 1    For i2 = r2_項目名行 + 1 To r2_end            If MyArray(i2, myDicCOL("区コード")) = MyArray(r2_項目名行 + 1, myDicCOL("区コード")) _            And (MyArray(i2, myDicCOL("カナ氏名（半角）")) <> "" Or MyArray(i2, myDicCOL("生年月日（西暦）")) <> "") Then
            '■ Select（s2）            s2.Activate            strSQL = "SELECT B.DC_RIYONO" & vbCrLf _                    & " FROM D_DT00 A" & vbCrLf _                    & " JOIN D_Common B" & vbCrLf _                    & " ON B.DC_KUCD = A.DT00_KUCD" & vbCrLf _                    & " AND B.DC_KJNONEW = A.DT00_KJNONEW" & vbCrLf _                    & " AND B.DC_SVCD=A.DT00_SVCD" & vbCrLf _                    & " AND B.DC_SEQ=A.DT00_SEQ" & vbCrLf _                    & " WHERE A.DT00_SIMEIK = '" & MyArray(i2, myDicCOL("カナ氏名（半角）")) & "'" & vbCrLf _                    & " AND A.DT00_SEIYMD = '" & MyArray(i2, myDicCOL("生年月日（西暦）")) & "'" & vbCrLf _                    & " AND B.DC_RIYONO IS NOT NULL" & vbCrLf _                    & " AND B.DC_RIYONO != ''"                    '■ ログファイル出力            Print #FileNumber, "--------------------------------------------------"            Print #FileNumber, strSQL                                '■ SQLの実行            Set rs = Nothing            rs.Open strSQL, cn            If Err.Number <> 0 Then                        '■ ログファイル出力                Print #FileNumber, "--------------------------------------------------"                Print #FileNumber, "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description                        '■ ログファイルクローズ                Close #FileNumber                        '■ データベース切断                f_データベース切断                        MsgBox "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description                f_結果NG                Exit Sub                    ElseIf rs.RecordCount > 0 Then                            '■ ログファイル出力                Print #FileNumber, "--------------------------------------------------"                Print #FileNumber, "⇒DC_RIYONO=" & rs![DC_RIYONO]                                w_str = MyArray(i2, myDicCOL("カナ氏名（半角）")) & "-" & MyArray(i2, myDicCOL("生年月日（西暦）"))                If Not myDic3.exists(w_str) Then                    myDic3.Add w_str, CStr(rs![DC_RIYONO])                End If                    End If
        End If            Next i2
    '■ ログファイルクローズ    Application.StatusBar = "【" & w_step & "】ログファイルクローズ": w_step = w_step + 1    Close #FileNumber        '■ データベース切断    Application.StatusBar = "【" & w_step & "】データベース切断": w_step = w_step + 1    f_データベース切断        '■ 「利用者番号２」設定（s2）    Application.StatusBar = "【" & w_step & "】「利用者番号２」設定": w_step = w_step + 1    For i2 = r2_項目名行 + 1 To r2_end                If MyArray(i2, myDicCOL("区コード")) = MyArray(r2_項目名行 + 1, myDicCOL("区コード")) _            And (MyArray(i2, myDicCOL("カナ氏名（半角）")) <> "" Or MyArray(i2, myDicCOL("生年月日（西暦）")) <> "") Then
            w_str = MyArray(i2, myDicCOL("カナ氏名（半角）")) & "-" & MyArray(i2, myDicCOL("生年月日（西暦）"))            If myDic3.exists(w_str) Then                MyArray(i2, myDicCOL("利用者番号2")) = myDic3(w_str)            Else                MyArray(i2, myDicCOL("利用者番号2")) = w_サービスコード & Left(w_区コード, 1) & Format(w_利用者番号, "0000")                myDic3.Add w_str, MyArray(i2, myDicCOL("利用者番号2"))                w_利用者番号 = w_利用者番号 + 1            End If
        End If    Next i2        '■ 配列からコピー（s2）    Application.StatusBar = "【" & w_step & "】配列からコピー": w_step = w_step + 1    s2.Range(s2.Cells(1, 1), s2.Cells(r2_end, c2_end)) = MyArray    s2.Range(s2.Cells(r2_項目名行 - 2, 1), s2.Cells(r2_end, c2_end)).Columns.AutoFit        '■ A1選択（s2）    Application.StatusBar = "【" & w_step & "】A1選択": w_step = w_step + 1    s2.Activate    f_A1選択        '■ 結果（s）    Application.StatusBar = "【" & w_step & "】結果": w_step = w_step + 1    s.Activate    f_結果OK        Application.StatusBar = False
End Sub

④

Option Explicit
Sub ④_Click()
    '入力内容変換    w_proc = "4"
    '■ 実行シート設定（s）    w_step = 1    Application.StatusBar = "【" & w_step & "】実行シート設定": w_step = w_step + 1    If f_実行シート設定 = False Then        MsgBox "実行シート設定" & "　エラー"        Exit Sub    End If        '■ 各区入力様式シート設定（s2）    Application.StatusBar = "【" & w_step & "】各区入力様式シート設定": w_step = w_step + 1    If f_各区入力様式シート設定 = False Then        MsgBox "各区入力様式シート設定" & "　エラー"        Exit Sub    End If        '■ 事業者マスタシート設定（s3）    Application.StatusBar = "【" & w_step & "】事業者マスタシート設定": w_step = w_step + 1    If f_事業者マスタ設定 = False Then        Exit Sub    End If        '■ 共有マスタシート設定（s3）    Application.StatusBar = "【" & w_step & "】共有マスタシート設定": w_step = w_step + 1    If f_共有マスタ設定 = False Then        Exit Sub    End If
    '■ 色クリア（s2）    Application.StatusBar = "【" & w_step & "】色クリア": w_step = w_step + 1    s2.Activate    If myDicCOL.exists("あんしんショートステイ　選択区分（１選択、０非選択）") Then        x = myDicCOL("あんしんショートステイ　選択区分（１選択、０非選択）")        With s2.Range(s2.Cells(r2_項目名行 + 1, x), s2.Cells(r2_項目名行 + 1, x))            .Interior.ColorIndex = xlNone        End With        x = myDicCOL("生活支援ショートステイ　選択区分（１選択、０非選択）")        With s2.Range(s2.Cells(r2_項目名行 + 1, x), s2.Cells(r2_項目名行 + 1, x))            .Interior.ColorIndex = xlNone        End With        x = myDicCOL("あんしんショートステイ　利用者負担額（円/日）")        With s2.Range(s2.Cells(r2_項目名行 + 1, x), s2.Cells(r2_項目名行 + 1, x))            .Interior.ColorIndex = xlNone        End With        x = myDicCOL("生活支援ショートステイ　利用者負担額（円/日）")        With s2.Range(s2.Cells(r2_項目名行 + 1, x), s2.Cells(r2_項目名行 + 1, x))            .Interior.ColorIndex = xlNone        End With    End If        '■ 配列にコピー（s2）    Application.StatusBar = "【" & w_step & "】配列にコピー": w_step = w_step + 1    s2.Activate    MyArray = s2.Range(s2.Cells(1, 1), s2.Cells(r2_end, c2_end))    Debug.Print "========================================================================="    Debug.Print LBound(MyArray, 1) & "-" & UBound(MyArray, 1)    Debug.Print LBound(MyArray, 2) & "-" & UBound(MyArray, 2)    Debug.Print "========================================================================="        '■ 入力内容変換（s2）    Application.StatusBar = "【" & w_step & "】入力内容変換": w_step = w_step + 1    For i2 = r2_項目名行 + 1 To r2_end            If MyArray(i2, 3) <> "" And MyArray(i2, 4) <> "" Then
            '----------------------------------------------------------------------------------------            '■ 事業者コード取得（おむつ、寝具）（s2）            w_str = "事業者コード／名称"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_事業者コード検索(MyArray(i2, x)) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 事業者コード取得（日常用具）（s2）            w_str = "火災警報器　事業者コード"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_事業者コード検索(MyArray(i2, x)) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 事業者コード取得（日常用具）（s2）            w_str = "自動消火器　事業者コード"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_事業者コード検索(MyArray(i2, x)) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 事業者コード取得（日常用具）（s2）            w_str = "電磁調理器　事業者コード"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_事業者コード検索(MyArray(i2, x)) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 事業者コード取得（配食）（s2）            w_str = "配食　地域包括支援センターコード／名称"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_事業者コード検索(MyArray(i2, x)) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 品名コード取得（s2）            w_str = "火災警報器　品名コード"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_品名コード検索(MyArray(i2, x), x) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 品名コード取得（s2）            w_str = "自動消火器　品名コード"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_品名コード検索(MyArray(i2, x), x) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '■ 品名コード取得（s2）            w_str = "電磁調理器　品名コード"            If myDicCOL.exists(w_str) Then                If MyArray(i2, 3) <> "" Then                    x = myDicCOL(w_str)                    If MyArray(i2, x) <> "" Then                        If IsNumeric(MyArray(i2, x)) = False Then                            If f_品名コード検索(MyArray(i2, x), x) Then                                MyArray(i2, x) = w_事業者コード                            Else                                s2.Cells(i2, myDicCOL(w_str)).Interior.ColorIndex = 6 '黄色                            End If                        End If                    End If                End If            End If                            '----------------------------------------------------------------------------------------            '移行データ番号（任意）            x = myDicCOL("移行データ番号（任意）")            If MyArray(i2, x) <> "" Then                MyArray(i2, x) = "" & Right(MyArray(i2, x), 6)            End If                '----------------------------------------------------------------------------------------            '生年月日（西暦）            x = myDicCOL("生年月日（西暦）")            If MyArray(i2, x) <> "" Then                If IsDate(MyArray(i2, x)) Then                    MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                Else                    If MyArray(i2, x) <> "" Then                        Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                            Case "S", "H", "R"                                MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                        End Select                    End If                End If            End If
            '----------------------------------------------------------------------------------------            '性別コード（1男、2女）            x = myDicCOL("性別コード（1男、2女）")            Select Case MyArray(i2, x)                Case "男"                    MyArray(i2, x) = "1"                Case "女"                    MyArray(i2, x) = "2"            End Select                    '----------------------------------------------------------------------------------------            '郵便番号            x = myDicCOL("郵便番号")            If MyArray(i2, x) <> "" Then                If Len(MyArray(i2, x)) < 8 Then                    MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                End If            End If
            '----------------------------------------------------------------------------------------            '申込代行者　郵便番号            w_str = "申込代行者　郵便番号"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If Len(MyArray(i2, x)) < 8 Then                        MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                    End If                End If            End If
            '----------------------------------------------------------------------------------------            'サービス決定通知送付先　郵便番号            w_str = "サービス決定通知送付先　郵便番号"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If Len(MyArray(i2, x)) < 8 Then                        MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                    End If                End If            End If
            '----------------------------------------------------------------------------------------            'サービス配送先　郵便番号            w_str = "サービス配送先　郵便番号"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If Len(MyArray(i2, x)) < 8 Then                        MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                    End If                End If            End If
            '----------------------------------------------------------------------------------------            'サービス利用に関する連絡先　郵便番号            w_str = "サービス利用に関する連絡先　郵便番号"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If Len(MyArray(i2, x)) < 8 Then                        MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                    End If                End If            End If
            '----------------------------------------------------------------------------------------            '配食　緊急連絡先１　郵便番号（ハイフン付き）            w_str = "配食　緊急連絡先１　郵便番号（ハイフン付き）"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If Len(MyArray(i2, x)) < 8 Then                        MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                    End If                End If            End If
            '----------------------------------------------------------------------------------------            '配食　緊急連絡先２　郵便番号（ハイフン付き）            w_str = "配食　緊急連絡先２　郵便番号（ハイフン付き）"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If Len(MyArray(i2, x)) < 8 Then                        MyArray(i2, x) = Left(MyArray(i2, x), 3) & "-" & Mid(MyArray(i2, x), 4, 4)                    End If                End If            End If
            '----------------------------------------------------------------------------------------            '生活保護の受給有無（1なし、2あり）            x = myDicCOL("生活保護の受給有無（1なし、2あり）")            If IsNumeric(MyArray(i2, x)) = False Then                Select Case MyArray(i2, x)                    Case "有", "生保"                        MyArray(i2, x) = 2                    Case Else                        MyArray(i2, x) = 1                End Select            End If                        '----------------------------------------------------------------------------------------            '階層（減免ありの所得段階区分）            w_str = "階層（減免ありの所得段階区分）"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If IsNumeric(MyArray(i2, x)) = False Then                    Select Case StrConv(Right(MyArray(i2, x), 2), vbNarrow)                        Case "1A"                            MyArray(i2, x) = 91                        Case "1B"                            MyArray(i2, x) = 92                        Case Else                            If InStr(1, MyArray(i2, x), "みなし1") > 0 Then                                MyArray(i2, x) = 1                            ElseIf InStr(1, MyArray(i2, x), "みなし2") > 0 Then                                MyArray(i2, x) = 2                            ElseIf InStr(1, MyArray(i2, x), "みなし3") > 0 Then                                MyArray(i2, x) = 3                            ElseIf InStr(1, MyArray(i2, x), "みなし4") > 0 Then                                MyArray(i2, x) = 4                            ElseIf InStr(1, MyArray(i2, x), "みなし5") > 0 Then                                MyArray(i2, x) = 5                            End If                    End Select                End If            End If
            '----------------------------------------------------------------------------------------            '適用所得段階　介護保険料:1 生保減免:2 任意:3            If myDicCOL.exists("階層（減免ありの所得段階区分）") And myDicCOL.exists("適用所得段階　介護保険料:1 生保減免:2 任意:3") Then                If MyArray(i2, myDicCOL("階層（減免ありの所得段階区分）")) <> "" Then                    MyArray(i2, myDicCOL("適用所得段階　介護保険料:1 生保減免:2 任意:3")) = 2                End If            End If
            '----------------------------------------------------------------------------------------            '要介護度            x = myDicCOL("要介護度")            If IsNumeric(MyArray(i2, x)) = False Then                Select Case MyArray(i2, x)                    Case "", "未更新"                        MyArray(i2, x) = 1                    Case "非該当", "申請中"                        MyArray(i2, x) = 2                    Case "要支援1", "支1"                        MyArray(i2, x) = 3                    Case "要支援2", "支2"                        MyArray(i2, x) = 4                    Case "要介護1", "介1"                        MyArray(i2, x) = 5                    Case "要介護2", "介2"                        MyArray(i2, x) = 6                    Case "要介護3", "介3"                        MyArray(i2, x) = 7                    Case "要介護4", "介4"                        MyArray(i2, x) = 8                    Case "要介護5", "介5"                        MyArray(i2, x) = 9                    Case Else                        MyArray(i2, x) = 2                End Select            End If
            '----------------------------------------------------------------------------------------            '要介護認定の有効期間　開始年月日            w_str = "要介護認定の有効期間　開始年月日"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsDate(MyArray(i2, x)) Then                        MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                    Else                        Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                            Case "S", "H", "R"                                MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '要介護認定の有効期間　終了年月日            w_str = "要介護認定の有効期間　終了年月日"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsDate(MyArray(i2, x)) Then                        MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                    Else                        Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                            Case "S", "H", "R"                                MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '申請年月日            x = myDicCOL("申請年月日")            If MyArray(i2, x) <> "" Then                If IsDate(MyArray(i2, x)) Then                    MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                Else                    Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                        Case "S", "H", "R"                            MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                    End Select                End If            End If
            '----------------------------------------------------------------------------------------            '決定年月日、決定区分            x = myDicCOL("決定年月日")            If MyArray(i2, x) <> "" Then                If IsDate(MyArray(i2, x)) Then                    MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                Else                    Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                        Case "S", "H", "R"                            MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                    End Select                End If                If MyArray(i2, myDicCOL("決定区分")) = "" Then                    MyArray(i2, myDicCOL("決定区分")) = 1                End If            End If
            '----------------------------------------------------------------------------------------            '決定年月日　決定、決定年月日、決定区分            x = myDicCOL("決定年月日　決定")            If MyArray(i2, x) <> "" Then                If IsDate(MyArray(i2, x)) Then                    MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                Else                    Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                        Case "S", "H", "R"                            MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                    End Select                End If                MyArray(i2, myDicCOL("決定区分")) = 4                MyArray(i2, myDicCOL("決定年月日")) = "" & MyArray(i2, x)            End If                        '----------------------------------------------------------------------------------------            '決定年月日　変更、決定年月日、決定区分            x = myDicCOL("決定年月日　変更")            If MyArray(i2, x) <> "" Then                If IsDate(MyArray(i2, x)) Then                    MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                Else                    Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                        Case "S", "H", "R"                            MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                    End Select                End If                MyArray(i2, myDicCOL("決定区分")) = 4                MyArray(i2, myDicCOL("決定年月日")) = "" & MyArray(i2, x)            End If                        '----------------------------------------------------------------------------------------            '決定年月日　廃止、決定年月日、決定区分            x = myDicCOL("決定年月日　廃止")            If MyArray(i2, x) <> "" Then                If IsDate(MyArray(i2, x)) Then                    MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                Else                    Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                        Case "S", "H", "R"                            MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                    End Select                End If                MyArray(i2, myDicCOL("決定区分")) = 4                MyArray(i2, myDicCOL("決定年月日")) = "" & MyArray(i2, x)            End If                        '----------------------------------------------------------------------------------------            '決定年月日　決定、決定年月日　変更、決定年月日　廃止            Select Case MyArray(i2, myDicCOL("決定区分"))                Case "1"                    MyArray(i2, myDicCOL("決定年月日　決定")) = MyArray(i2, myDicCOL("決定年月日"))                Case "3"                    MyArray(i2, myDicCOL("決定年月日　変更")) = MyArray(i2, myDicCOL("決定年月日"))                Case "4"                    MyArray(i2, myDicCOL("決定年月日　廃止")) = MyArray(i2, myDicCOL("決定年月日"))            End Select                        '----------------------------------------------------------------------------------------            'あんしんショートステイ、生活支援ショートステイ            If myDicCOL.exists("あんしんショートステイ　選択区分（１選択、０非選択）") _                And myDicCOL.exists("生活支援ショートステイ　選択区分（１選択、０非選択）") _                And myDicCOL.exists("あんしんショートステイ　利用者負担額（円/日）") _                And myDicCOL.exists("生活支援ショートステイ　利用者負担額（円/日）") Then                If (MyArray(i2, myDicCOL("あんしんショートステイ　選択区分（１選択、０非選択）")) <> "" _                    And MyArray(i2, myDicCOL("生活支援ショートステイ　選択区分（１選択、０非選択）")) <> "") _                    Or (MyArray(i2, myDicCOL("あんしんショートステイ　利用者負担額（円/日）")) <> "" _                    And MyArray(i2, myDicCOL("生活支援ショートステイ　利用者負担額（円/日）")) <> "") Then                    s2.Activate                    MsgBox "「あんしん」と「生活支援」を同時に入力する事は、出来ません。"                    s2.Cells(i2, myDicCOL("あんしんショートステイ　選択区分（１選択、０非選択）")).Interior.ColorIndex = 6 '黄色                    s2.Cells(i2, myDicCOL("生活支援ショートステイ　選択区分（１選択、０非選択）")).Interior.ColorIndex = 6 '黄色                    s2.Cells(i2, myDicCOL("あんしんショートステイ　利用者負担額（円/日）")).Interior.ColorIndex = 6 '黄色                    s2.Cells(i2, myDicCOL("生活支援ショートステイ　利用者負担額（円/日）")).Interior.ColorIndex = 6 '黄色                    f_結果NG                    Exit Sub                End If            End If
            '----------------------------------------------------------------------------------------            'サービス決定通知送付先　決定CD            w_str = "サービス決定通知送付先　決定CD"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "申込者", "利用者"                                MyArray(i2, x) = 1                            Case "代行者", "代行者等", "介護者等"                                MyArray(i2, x) = 2                            Case Else                                MyArray(i2, x) = 3                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '申込代行者　続柄            w_str = "申込代行者　続柄"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "本人"                                MyArray(i2, x) = 1                            Case "妻", "夫"                                MyArray(i2, x) = 2                            Case "子"                                MyArray(i2, x) = 3                            Case "父", "母"                                MyArray(i2, x) = 4                            Case "兄", "弟", "姉", "妹"                                MyArray(i2, x) = 5                            Case "その他"                                MyArray(i2, x) = 90                            Case "大家"                                MyArray(i2, x) = 21                            Case "鍵管理人"                                MyArray(i2, x) = 22                            Case "ケアマネージャー"                                MyArray(i2, x) = 23                            Case Else                                MyArray(i2, x) = 99                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            'サービス決定通知送付先　続柄            w_str = "サービス決定通知送付先　続柄"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "本人"                                MyArray(i2, x) = 1                            Case "妻", "夫"                                MyArray(i2, x) = 2                            Case "子"                                MyArray(i2, x) = 3                            Case "父", "母"                                MyArray(i2, x) = 4                            Case "兄", "弟", "姉", "妹"                                MyArray(i2, x) = 5                            Case "その他"                                MyArray(i2, x) = 90                            Case "大家"                                MyArray(i2, x) = 21                            Case "鍵管理人"                                MyArray(i2, x) = 22                            Case "ケアマネージャー"                                MyArray(i2, x) = 23                            Case Else                                MyArray(i2, x) = 99                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '配食　緊急連絡先１　続柄            w_str = "配食　緊急連絡先１　続柄"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "本人"                                MyArray(i2, x) = 1                            Case "妻", "夫"                                MyArray(i2, x) = 2                            Case "子"                                MyArray(i2, x) = 3                            Case "父", "母"                                MyArray(i2, x) = 4                            Case "兄", "弟", "姉", "妹"                                MyArray(i2, x) = 5                            Case "その他"                                MyArray(i2, x) = 90                            Case "大家"                                MyArray(i2, x) = 21                            Case "鍵管理人"                                MyArray(i2, x) = 22                            Case "ケアマネージャー"                                MyArray(i2, x) = 23                            Case Else                                MyArray(i2, x) = 99                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '配食　緊急連絡先２　続柄            w_str = "配食　緊急連絡先２　続柄"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "本人"                                MyArray(i2, x) = 1                            Case "妻", "夫"                                MyArray(i2, x) = 2                            Case "子"                                MyArray(i2, x) = 3                            Case "父", "母"                                MyArray(i2, x) = 4                            Case "兄", "弟", "姉", "妹"                                MyArray(i2, x) = 5                            Case "その他"                                MyArray(i2, x) = 90                            Case "大家"                                MyArray(i2, x) = 21                            Case "鍵管理人"                                MyArray(i2, x) = 22                            Case "ケアマネージャー"                                MyArray(i2, x) = 23                            Case Else                                MyArray(i2, x) = 99                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '電話種類(１高齢者用、２自己)            w_str = "電話種類(１高齢者用、２自己)"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "自己電話"                                MyArray(i2, x) = 2                            Case Else                                MyArray(i2, x) = 1                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '緊急通報システムとの併用区分            w_str = "緊急通報システムとの併用区分"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsNumeric(MyArray(i2, x)) = False Then                        Select Case MyArray(i2, x)                            Case "有"                                MyArray(i2, x) = 2                            Case Else                                MyArray(i2, x) = 1                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '配食　有効期限　開始年月日            w_str = "配食　有効期限　開始年月日"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsDate(MyArray(i2, x)) Then                        MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                    Else                        Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                            Case "S", "H", "R"                                MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '配食　有効期限　終了年月日            w_str = "配食　有効期限　終了年月日"            If myDicCOL.exists(w_str) Then                x = myDicCOL(w_str)                If MyArray(i2, x) <> "" Then                    If IsDate(MyArray(i2, x)) Then                        MyArray(i2, x) = "" & Format(MyArray(i2, x), "yyyymmdd")                    Else                        Select Case StrConv(Left(MyArray(i2, x), 1), vbUpperCase)                            Case "S", "H", "R"                                MyArray(i2, x) = f_年月日変換(MyArray(i2, x))                        End Select                    End If                End If            End If                        '----------------------------------------------------------------------------------------            '登録操作者コード            MyArray(i2, myDicCOL("登録操作者コード")) = "DATA-IKOU"                '登録年月日時分秒            MyArray(i2, myDicCOL("登録年月日時分秒")) = "GETDATE()"                '更新操作者コード            MyArray(i2, myDicCOL("更新操作者コード")) = "DATA-IKOU"                '更新年月日時分秒            MyArray(i2, myDicCOL("更新年月日時分秒")) = "GETDATE()"                '更新日時            MyArray(i2, myDicCOL("更新日時")) = "GETDATE()"                '作成日時            MyArray(i2, myDicCOL("作成日時")) = "GETDATE()"                '登録日（年月日時分秒）            MyArray(i2, myDicCOL("登録日（年月日時分秒）")) = "GETDATE()"                    End If            Next i2        '■ 入力内容長さチェック（s2）    Application.StatusBar = "【" & w_step & "】入力内容長さチェック": w_step = w_step + 1    For i2 = r2_項目名行 + 1 To r2_end                If MyArray(i2, 3) <> "" And MyArray(i2, 4) <> "" Then            For j2 = 3 To c2_end_tbl                If MyArray(i2, j2) <> "" Then                    If Len(MyArray(i2, j2)) > MyArray(15, j2) Then                        If MyArray(i2, j2) <> "GETDATE()" Then                                                        s2.Activate                            w_エラー内容 = "入力内容長さエラー" & vbCrLf _                                            & "「" & s2.Cells(r2_項目名行, j2) & "」：" & MyArray(i2, j2) & "、行：" & i2                            MsgBox w_エラー内容                            f_結果NG                            Exit Sub                                                    End If                    End If                End If            Next j2        End If        Next i2        '■ 配列からコピー（s2）    Application.StatusBar = "【" & w_step & "】配列からコピー": w_step = w_step + 1    s2.Range(s2.Cells(1, 1), s2.Cells(r2_end, c2_end)).NumberFormatLocal = "G/標準"    s2.Range(s2.Cells(1, 1), s2.Cells(r2_end, c2_end)) = MyArray    s2.Range(s2.Cells(r2_項目名行 - 2, 1), s2.Cells(r2_end, c2_end)).Columns.AutoFit        '■ A1選択（s2）    Application.StatusBar = "【" & w_step & "】A1選択": w_step = w_step + 1    s2.Activate    f_A1選択        '■ 結果（s）    Application.StatusBar = "【" & w_step & "】結果": w_step = w_step + 1    s.Activate    f_結果OK        Application.StatusBar = False
End Sub

⑤

Option Explicit
Sub ⑤_Click()
    'Insert文作成    w_proc = "5"
    '■ 実行シート設定（s）    w_step = 1    Application.StatusBar = "【" & w_step & "】実行シート設定": w_step = w_step + 1    If f_実行シート設定 = False Then        MsgBox "実行シート設定" & "　エラー"        Exit Sub    End If        '■ 各区入力様式シート設定（s2）    Application.StatusBar = "【" & w_step & "】各区入力様式シート設定": w_step = w_step + 1    If f_各区入力様式シート設定 = False Then        MsgBox "各区入力様式シート設定" & "　エラー"        Exit Sub    End If        '■ 結果列クリア    Application.StatusBar = "【" & w_step & "】結果列クリア": w_step = w_step + 1    s2.Range(s2.Cells(r2_項目名行 + 1, myDicCOL("決定サービス別")), s2.Cells(r2_end, c2_end)).ClearContents        '■ ログファイルオープン    Application.StatusBar = "【" & w_step & "】ログファイルオープン": w_step = w_step + 1    FileNumber = FreeFile    w_ログファイル名 = w_ブック名 & "_LOG⑤A.txt"    Open ThisWorkbook.Path & "\" & w_ログファイル名 For Output As #FileNumber        '■ 配列にコピー（s2）    Application.StatusBar = "【" & w_step & "】配列にコピー": w_step = w_step + 1    s2.Activate    MyArray = s2.Range(s2.Cells(1, 1), s2.Cells(r2_end, c2_end))    Debug.Print "========================================================================="    Debug.Print LBound(MyArray, 1) & "-" & UBound(MyArray, 1)    Debug.Print LBound(MyArray, 2) & "-" & UBound(MyArray, 2)    Debug.Print "========================================================================="        '■ SQL文作成（s2）    Application.StatusBar = "【" & w_step & "】SQL文作成": w_step = w_step + 1    c_sql = myDicCOL("決定サービス別")    For x = 2 To r2_end            If MyArray(x, 1) = "●" Then                    For i2 = r2_項目名行 + 1 To r2_end                            If MyArray(i2, 3) <> "" And MyArray(i2, 4) <> "" Then                                    '■ メモが空白の場合は、メモ作成対象外                    If MyArray(x + 1, 2) <> "D_SVMemo" Or MyArray(i2, myDicCOL("メモ")) <> "" Then
                        '■ 列名編集                        w_str1 = ""                        For j2 = 3 To c2_end                            If MyArray(x, j2) <> "" And MyArray(x, j2) <> "※" Then                                        If MyArray(x + 1, j2) = "" Then                                    '■ ログファイルクローズ                                    Close #FileNumber                                    '■ エラー                                    s2.Activate                                    MyArray(x, j2).Select                                    MsgBox "各区入力様式の「列名」がありません。"                                    f_結果NG                                    Exit Sub                                End If                                                                If w_str1 <> "" Then                                    w_str1 = w_str1 & vbCrLf & " ,"                                End If                                                                w_str1 = w_str1 & MyArray(x + 1, j2)                                                            End If                        Next j2                                                '----------------------------------------------------------------------------------------                        '全サービス                        Select Case MyArray(x + 1, 2)                            Case "D_DT02", "D_DT03", "D_DT04", "D_DT06", "D_DT07", "D_DT08", "D_DT09", "D_DT10"                                                            '申込代行者　電話番号１（固定）                                w_str1 = w_str1 & vbCrLf & " ," & MyArray(x + 1, myDicCOL("申込代行者　電話番号１（固定）"))                                                        End Select                                                '----------------------------------------------------------------------------------------                        'ショート                        If MyArray(x + 1, 2) = "D_DT02" Then                                                        'あんしんショートステイ　選択区分（１選択、０非選択）                            w_str1 = w_str1 & vbCrLf & " ,DT02_SENTAKU1"                            w_str1 = w_str1 & vbCrLf & " ,DT02_RKIN1"                                                End If                                                '----------------------------------------------------------------------------------------                        '日用用具                        Select Case MyArray(x + 1, 2)                            Case "D_DT07"                                                            'サービス利用に関する連絡先　電話番号１（　固定　）                                w_str1 = w_str1 & vbCrLf & " ," & MyArray(x + 1, myDicCOL("サービス利用に関する連絡先　電話番号１（　固定　）"))                                                        End Select                                                '■ 値編集                        w_str2 = ""                        For j2 = 3 To c2_end                            If MyArray(x, j2) <> "" And MyArray(x, j2) <> "※" Then                                                                    If w_str2 <> "" Then                                    w_str2 = w_str2 & vbCrLf & " ,"                                End If                                                                If MyArray(x + 2, j2) = "DECIMAL" Then                                    If MyArray(i2, j2) = "" Then                                        w_long = 0                                    ElseIf IsNumeric(MyArray(i2, j2)) = False Then                                        w_long = 0                                    Else                                        w_long = CLng(MyArray(i2, j2))                                    End If                                    w_str2 = w_str2 & w_long                                                                    ElseIf MyArray(x + 2, j2) = "DATETIME" Then                                    If MyArray(i2, j2) = "GETDATE()" Then                                        w_str2 = w_str2 & MyArray(i2, j2)                                    Else                                        w_str2 = w_str2 & "'" & MyArray(i2, j2) & "'"                                    End If                                                                    ElseIf MyArray(x + 2, j2) = "BIT" Then                                    If MyArray(i2, j2) = "" Then                                        w_long = 0                                    ElseIf MyArray(i2, j2) = "0" Then                                        w_long = 0                                    Else                                        w_long = 1                                    End If                                    w_str2 = w_str2 & w_long                                                                    Else                                    w_str2 = w_str2 & "'" & MyArray(i2, j2) & "'"                                                                                                        End If                                                    End If                        Next j2                                '----------------------------------------------------------------------------------------                        '全サービス                        Select Case MyArray(x + 1, 2)                            Case "D_DT02", "D_DT03", "D_DT04", "D_DT06", "D_DT07", "D_DT08", "D_DT09", "D_DT10"                                                            '申込代行者　電話番号１（固定）                                If MyArray(i2, myDicCOL("申込代行者　電話番号２（携帯）")) <> "" Then                                    w_str2 = w_str2 & vbCrLf & " ," & "'" & MyArray(i2, myDicCOL("申込代行者　電話番号２（携帯）")) & "'"                                Else                                    w_str2 = w_str2 & vbCrLf & " ," & "'" & MyArray(i2, myDicCOL("申込代行者　電話番号１（固定）")) & "'"                                End If                                                        End Select                                                '----------------------------------------------------------------------------------------                        'ショート                        If MyArray(x + 1, 2) = "D_DT02" Then                                                        'あんしんショートステイ　選択区分（１選択、０非選択）                            If MyArray(i2, myDicCOL("あんしんショートステイ　選択区分（１選択、０非選択）")) = "1" Then                                w_str2 = w_str2 & vbCrLf & " ," & "1"                            ElseIf MyArray(i2, myDicCOL("生活支援ショートステイ　選択区分（１選択、０非選択）")) = "1" Then                                w_str2 = w_str2 & vbCrLf & " ," & "2"                            Else                                w_str2 = w_str2 & vbCrLf & " ,0"                            End If                                                    'あんしんショートステイ　利用者負担額（円/日）                            If MyArray(i2, myDicCOL("あんしんショートステイ　利用者負担額（円/日）")) <> "" Then                                w_str2 = w_str2 & vbCrLf & " ," & MyArray(i2, myDicCOL("あんしんショートステイ　利用者負担額（円/日）"))                            ElseIf MyArray(i2, myDicCOL("生活支援ショートステイ　利用者負担額（円/日）")) <> "" Then                                w_str2 = w_str2 & vbCrLf & " ," & MyArray(i2, myDicCOL("生活支援ショートステイ　利用者負担額（円/日）"))                            Else                                w_str2 = w_str2 & vbCrLf & " ,0"                            End If                                                    End If                                                '----------------------------------------------------------------------------------------                        '日用用具                        Select Case MyArray(x + 1, 2)                            Case "D_DT07"                                                            'サービス利用に関する連絡先　電話番号１（　固定　）                                If MyArray(i2, myDicCOL("サービス利用に関する連絡先　電話番号１（　固定　）")) <> "" Then                                    w_str2 = w_str2 & vbCrLf & " ," & "'" & MyArray(i2, myDicCOL("サービス利用に関する連絡先　電話番号２（　携帯　）")) & "'"                                Else                                    w_str2 = w_str2 & vbCrLf & " ," & "'" & MyArray(i2, myDicCOL("サービス利用に関する連絡先　電話番号１（　固定　）")) & "'"                                End If                                                        End Select                                                '■ SQL編集                        w_sql = "INSERT INTO " & MyArray(x + 1, 2) & vbCrLf & " ("                        w_sql = w_sql & w_str1                        w_sql = w_sql & ")" & vbCrLf & " VALUES" & vbCrLf & " ("                        w_sql = w_sql & w_str2                        w_sql = w_sql & ")"                                                '■ SQLセット                        MyArray(i2, c_sql) = w_sql                                                '■ ログファイル出力                        Print #FileNumber, "--------------------------------------------------"                        Print #FileNumber, w_sql                                        End If                                    End If                        Next i2                c_sql = c_sql + 1            End If            Next x        '■ ログファイルクローズ    Application.StatusBar = "【" & w_step & "】ログファイルクローズ": w_step = w_step + 1    Close #FileNumber        '■ ログファイルオープン    Application.StatusBar = "【" & w_step & "】ログファイルオープン": w_step = w_step + 1    FileNumber = FreeFile    w_ログファイル名 = w_ブック名 & "_LOG⑤B.txt"    Open ThisWorkbook.Path & "\" & w_ログファイル名 For Output As #FileNumber        '■ サーバー情報設定    Application.StatusBar = "【" & w_step & "】サーバー情報設定": w_step = w_step + 1    f_サーバー情報設定        '■ データベース接続    Application.StatusBar = "【" & w_step & "】データベース接続": w_step = w_step + 1    If f_データベース接続 = False Then        MsgBox "データベース接続　エラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description        Exit Sub    End If        '■ Delete（s2）    Application.StatusBar = "【" & w_step & "】Delete": w_step = w_step + 1    s2.Activate    strSQL = ""    For x = 2 To r2_end        If s2.Cells(x, 1).Value = "●" Then            strSQL = strSQL & "DELETE FROM " & s2.Cells(x + 1, 2).Value & vbCrLf _                    & " WHERE [" & s2.Cells(x + 1, myDicCOL("サービスコード")) & "] = " & s2.Cells(r2_項目名行 + 1, myDicCOL("サービスコード")).Value & vbCrLf _                    & " AND [" & s2.Cells(x + 1, myDicCOL("区コード")).Value & "] = " & s2.Cells(r2_項目名行 + 1, myDicCOL("区コード")).Value & vbCrLf        End If    Next x        '■ ログファイル出力    Application.StatusBar = "【" & w_step & "】ログファイル出力": w_step = w_step + 1    Print #FileNumber, "--------------------------------------------------"    Print #FileNumber, strSQL        '■ SQLの実行    Application.StatusBar = "【" & w_step & "】SQLの実行": w_step = w_step + 1    On Error Resume Next    rs.Open strSQL, cn    If Err.Number <> 0 Then                '■ ログファイル出力        Print #FileNumber, "--------------------------------------------------"        Print #FileNumber, "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description                '■ ログファイルクローズ        Close #FileNumber                '■ データベース切断        f_データベース切断            MsgBox "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description        f_結果NG        Exit Sub        End If    On Error GoTo 0        '■ Insert（s2）    Application.StatusBar = "【" & w_step & "】Insert": w_step = w_step + 1    s2.Activate    On Error Resume Next    For i2 = r2_項目名行 + 1 To r2_end        For j2 = myDicCOL("決定サービス別") To myDicCOL("サービスメモ")                If MyArray(i2, j2) <> "" Then                            '■ SQLセット                strSQL = MyArray(i2, j2)                                '■ SQLの実行                rs.Open strSQL, cn                If Err.Number <> 0 Then                                        '■ ログファイル出力                    Print #FileNumber, "--------------------------------------------------"                    Print #FileNumber, strSQL                                        '■ ログファイル出力                    Print #FileNumber, "--------------------------------------------------"                    Print #FileNumber, "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description                                        '■ ログファイルクローズ                    Close #FileNumber                                        '■ データベース切断                    f_データベース切断                                    '■ 行調整                    s2.Rows(r2_項目名行 + 1 & ":" & r2_end).Select                    Selection.RowHeight = 18                                        '■ エラー                    MsgBox "DBエラー" & vbCrLf & "(" & Err.Number & ")" & Err.Description                    f_結果NG                    Exit Sub                                End If                    End If                Next j2    Next i2    On Error GoTo 0        '■ ログファイルクローズ    Application.StatusBar = "【" & w_step & "】ログファイルクローズ": w_step = w_step + 1    Close #FileNumber        '■ データベース切断    Application.StatusBar = "【" & w_step & "】データベース切断": w_step = w_step + 1    f_データベース切断        '■ A1選択（s2）    Application.StatusBar = "【" & w_step & "】A1選択": w_step = w_step + 1    s2.Activate    f_A1選択        '■ 結果（s）    Application.StatusBar = "【" & w_step & "】結果": w_step = w_step + 1    s.Activate    f_結果OK        Application.StatusBar = False
End Sub

X①

Option Explicit
Sub X①_Click() '対象「各区入力様式」ファイル指定 w_proc = "X1" '■ ファイル選択（s） w_step = 1 Application.StatusBar = "【" & w_step & "】ファイル選択": w_step = w_step + 1 Set s = ActiveSheet With Application.FileDialog(msoFileDialogFilePicker) .Title = "ファイルを選択してください。" .Filters.Clear .Filters.Add "エクセルファイル", "*.xlsx" .FilterIndex = 1 .AllowMultiSelect = False .InitialFileName = ActiveWorkbook.Path & "\" w_ret = .Show If w_ret <> 0 Then s.Range("_X①").Value = .SelectedItems.Item(1) s.Range("_X①").Columns.AutoFit s.Range("_①").Value = .SelectedItems.Item(1) s.Range("_A①").Value = .SelectedItems.Item(1) s.Range("_B①").Value = .SelectedItems.Item(1) '■ 実行シート設定（s） If f_実行シート設定 = False Then MsgBox "実行シート設定" & "　エラー" Exit Sub End If '■ 各区入力様式シート設定（s2） If f_各区入力様式シート設定 = False Then MsgBox "各区入力様式シート設定" & "　エラー" Exit Sub End If s.Activate Else MsgBox "キャンセルされました。" End If End With
End Sub

X②

Option Explicit
Sub X②_Click()
'個人情報項目編集 w_proc = "X2"
'■ 実行シート設定（s） w_step = 1 Application.StatusBar = "【" & w_step & "】実行シート設定": w_step = w_step + 1 If f_実行シート設定 = False Then MsgBox "実行シート設定" & "　エラー" Exit Sub End If '■ 各区入力様式シート設定（s2） Application.StatusBar = "【" & w_step & "】各区入力様式シート設定": w_step = w_step + 1 If f_各区入力様式シート設定 = False Then MsgBox "各区入力様式シート設定" & "　エラー" Exit Sub End If '■ 個人情報項目編集（s2） Application.StatusBar = "【" & w_step & "】個人情報項目編集": w_step = w_step + 1 s2.Activate On Error Resume Next Debug.Print s2.ListObjects(1).Name If Err.Number <> 0 Then MsgBox "テーブルのあるシートで実行してください。" Exit Sub End If On Error GoTo 0 With s2.ListObjects(1).ListColumns("項目名").DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=row()-" & r2_項目名行 End With With s2.ListObjects(1).ListColumns("介護保険証の被保険者番号").DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=TEXT([@項目名],""0000000000"")" End With With s2.ListObjects(1).ListColumns("漢字氏名").DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=""漢字氏名""&[@項目名]" End With With s2.ListObjects(1).ListColumns("カナ氏名（半角）").DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=""ｶﾅｼﾒｲ""&[@項目名]" End With With s2.ListObjects(1).ListColumns("生年月日（西暦）").DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "H1.1.1" End With With s2.ListObjects(1).ListColumns("郵便番号").DataBodyRange .HorizontalAlignment = xlLeft .ClearContents .Value = "111-2222" End With With s2.ListObjects(1).ListColumns("住所").DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=""住所""&[@項目名]" End With With s2.ListObjects(1).ListColumns("電話番号１（固定）").DataBodyRange .HorizontalAlignment = xlLeft .ClearContents .Value = "1111-222-3333" End With With s2.ListObjects(1).ListColumns("電話番号２（携帯）").DataBodyRange .HorizontalAlignment = xlLeft .ClearContents .Value = "111-2222-3333" End With w_str = "サービス決定通知送付先　郵便番号" If myDicCOL.exists(w_str) Then With s2.ListObjects(1).ListColumns(w_str).DataBodyRange .HorizontalAlignment = xlLeft .ClearContents .Value = "111-2222" End With End If w_str = "サービス決定通知送付先　住所" If myDicCOL.exists(w_str) Then With s2.ListObjects(1).ListColumns(w_str).DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=""住所""&[@項目名]" End With End If w_str = "サービス決定通知送付先　電話番号" If myDicCOL.exists(w_str) Then With s2.ListObjects(1).ListColumns(w_str).DataBodyRange .HorizontalAlignment = xlLeft .ClearContents .Value = "1111-222-3333" End With End If w_str = "サービス決定通知送付先　氏名" If myDicCOL.exists(w_str) Then With s2.ListObjects(1).ListColumns(w_str).DataBodyRange .HorizontalAlignment = xlLeft .NumberFormatLocal = "G/標準" .ClearContents .Value = "=""氏名""&[@項目名]" End With End If s2.ListObjects(1).Range.Columns.AutoFit '■ キー項目チェック（s2） Application.StatusBar = "【" & w_step & "】キー項目チェック": w_step = w_step + 1 If s2.ListObjects(1).ListColumns("サービスコード").DataBodyRange(1) = "" Then MsgBox "「サービスコード」を入力してください。" End If If s2.ListObjects(1).ListColumns("区コード").DataBodyRange(1) = "" Then MsgBox "「区コード」を入力してください。" End If '■ 改行なし（s2） Application.StatusBar = "【" & w_step & "】改行なし": w_step = w_step + 1 Cells.WrapText = False '■ A1選択（s2） Application.StatusBar = "【" & w_step & "】A1選択": w_step = w_step + 1 s2.Activate f_A1選択 '■ 結果（s） Application.StatusBar = "【" & w_step & "】結果": w_step = w_step + 1 s.Activate f_結果OK
End Sub