部品

With s0_グループ対応表
.Activate .Cells.EntireColumn.AutoFit
'◆ テーブル追加 If p_type = "樹脂加工" Then .Range(d0_グループ対応表x("①基本") & "1").Value = "" .Range(d0_グループ対応表x("①基本") & "2").Select Selection.CurrentRegion.Select Set tbl = .ListObjects.Add(xlSrcRange, Selection, , xlYes) tbl.Name = "Table1" tbl.TableStyle = "TableStyleMedium2" Range(d0_グループ対応表x("①基本") & "1").Value = "①樹脂加工部" Else .Range(d0_グループ対応表x("②基本") & "1").Value = "" .Range(d0_グループ対応表x("②基本") & "2").Select Selection.CurrentRegion.Select Set tbl = .ListObjects.Add(xlSrcRange, Selection, , xlYes) tbl.Name = "Table2" tbl.TableStyle = "TableStyleMedium7" Range(d0_グループ対応表x("②基本") & "1").Value = "②テクマック事業部" End If
End With

テーブル削除

With s0_グループ対応表 '◆ テーブル削除 .Activate For Each tbl In .ListObjects Set rngBody = tbl.DataBodyRange If Not rngBody Is Nothing Then rngBody.Delete End If tbl.Unlist Next tbl End With

テーブル削除

With s0_グループ対応表 .Activate On Error Resume Next If p_type = "樹脂加工" Then Set tbl = ws.ListObjects("Table1") Else Set tbl = ws.ListObjects("Table2") End If On Error GoTo 0 '◆ テーブル削除 If Not tbl Is Nothing Then If tbl.ListRows.Count > 0 Then tbl.DataBodyRange.Delete End If tbl.Unlist End If End With

＜配列＞

配列へセット、シートへ貼り付け

    '==============    ' 給与情報編集    '==============    With s0_給与情報            '◆ 全行表示        On Error Resume Next        .ShowAllData        On Error GoTo 0
        '◆ 配列へセット        With s0_名前コード表            On Error Resume Next            .ShowAllData            On Error GoTo 0            h0_名前コード表 = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell)).Value        End With
        '◆ 配列へセット        h0_給与情報 = .Range("A1", .Cells.SpecialCells(xlCellTypeLastCell)).Value                '◆ 姓編集        For i = 2 To UBound(h0_給与情報, 1)                    w_int = InStr(1, h0_給与情報(i, d0_給与情報("氏名")), "　")                    If w_int = 0 Then                w_int = InStr(1, h0_給与情報(i, d0_給与情報("氏名")), " ")            End If                    If w_int > 0 Then                h0_給与情報(i, d0_給与情報("姓")) = Left(h0_給与情報(i, d0_給与情報("氏名")), w_int - 1)            Else                h0_給与情報(i, d0_給与情報("姓")) = h0_給与情報(i, d0_給与情報("氏名"))            End If                    Next i            '◆ シートへ貼り付け        .Range("A1", .Cells(UBound(h0_給与情報, 1), UBound(h0_給与情報, 2))).Value = h0_給与情報                '◆ 列幅調整        .Cells.EntireColumn.AutoFit        End With

＜プロシージャ＞

Workbook_Open

Private Sub Workbook_Open()
'◆ 初期表示 Worksheets("メニュー").Activate Range("B15").Select
End Sub

Workbook_BeforeSave

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim ws As Worksheet        Dim rng1 As Range    Dim rng2 As Range    Dim rng3 As Range        Dim listSheet As Worksheet        Dim listRange1 As Range    Dim listRange2 As Range    Dim listRange3 As Range        '◆ データの入力規則設定    Set ws = ThisWorkbook.Sheets("メニュー")    Set rng1 = ws.Range("_①「経費明細」今年度")    Set rng2 = ws.Range("_②「報告書」先月")    Set rng3 = ws.Range("_③「報告書」更新対象")        Set listSheet = ThisWorkbook.Sheets("指定履歴")    Set listRange1 = listSheet.Range("A:A")    Set listRange2 = listSheet.Range("B:B")    Set listRange3 = listSheet.Range("C:C")
    ws.Cells.Validation.Delete
    On Error Resume Next        rng1.Validation.Add Type:=xlValidateList, _                            AlertStyle:=xlValidAlertStop, _                            Operator:=xlBetween, _                            Formula1:="='" & listSheet.Name & "'!" & listRange1.Address            rng2.Validation.Add Type:=xlValidateList, _                            AlertStyle:=xlValidAlertStop, _                            Operator:=xlBetween, _                            Formula1:="='" & listSheet.Name & "'!" & listRange2.Address            rng3.Validation.Add Type:=xlValidateList, _                            AlertStyle:=xlValidAlertStop, _                            Operator:=xlBetween, _                            Formula1:="='" & listSheet.Name & "'!" & listRange3.Address    On Error GoTo 0
End Sub

Worksheet_SelectionChange

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    '■■■■■■■■■■■■■■■■■    Application.EnableEvents = False    '■■■■■■■■■■■■■■■■■
    '◆ セル移動    If Target(1).Value = "▼" Then        Target(1).Offset(0, -1).Select    End If
    '■■■■■■■■■■■■■■■■■    Application.EnableEvents = True    '■■■■■■■■■■■■■■■■■    End Sub

Worksheet_Change

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim w_range As Range            '◆ ハイパーリンク削除    If Target.Hyperlinks.Count > 0 Then            Set w_range = Target.MergeArea                Target.Hyperlinks.Delete
        With w_range                    .Merge                    With .Interior                .Pattern = xlSolid                .PatternColorIndex = xlAutomatic                .ThemeColor = xlThemeColorAccent5                .TintAndShade = 0.799981688894314                .PatternTintAndShade = 0            End With
            With .Borders(xlEdgeLeft)                .LineStyle = xlContinuous                .ColorIndex = 0                .TintAndShade = 0                .Weight = xlThin            End With
            With .Borders(xlEdgeTop)                .LineStyle = xlContinuous                .ColorIndex = 0                .TintAndShade = 0                .Weight = xlThin            End With
            With .Borders(xlEdgeBottom)                .LineStyle = xlContinuous                .ColorIndex = 0                .TintAndShade = 0                .Weight = xlThin            End With
            With .Borders(xlEdgeRight)                .LineStyle = xlContinuous                .ColorIndex = 0                .TintAndShade = 0                .Weight = xlThin            End With
            With .Font                .Name = "Meiryo UI"                .Size = 10                .Strikethrough = False                .Superscript = False                .Subscript = False                .OutlineFont = False                .Shadow = False                .Underline = xlUnderlineStyleNone                .ThemeColor = xlThemeColorLight1                .TintAndShade = 0                .ThemeFont = xlThemeFontNone            End With                End With            End If
    '◆ 指定履歴追加    If Not ActiveCell.Validation Is Nothing Then            If f_指定履歴追加(Target.Value, Target.Address) = False Then            MsgBox "指定履歴の追加が、できませんでした。", vbOKOnly + vbExclamation, "指定履歴追加エラー"        End If            End If
    '◆ 処理年月編集    If Target.Address = Range("_②「報告書」先月").Address Then            '■■■■■■■■■■■■■■■■■        Application.EnableEvents = False        Application.ScreenUpdating = False        '■■■■■■■■■■■■■■■■■                            Call f_処理年月編集                '■■■■■■■■■■■■■■■■■        Application.ScreenUpdating = True        Application.EnableEvents = True        '■■■■■■■■■■■■■■■■■                    End If    End Sub

Click

Sub ②報告書作成_Click()
'■■■■■■■■■■■■■■■■■■■■■■■■ Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '■■■■■■■■■■■■■■■■■■■■■■■■ If f_シート設定 = False Then GoTo l_ext If f_列位置設定_グループ対応表 = False Then GoTo l_ext If f_報告書作成("②作成") = False Then GoTo l_ext
l_ext:
'■■■■■■■■■■■■■■■■■■■■■■■■ Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.EnableEvents = True Application.StatusBar = False '■■■■■■■■■■■■■■■■■■■■■■■■
End Sub

＜セル＞

カーソルを左にずらす

Private Sub Worksheet_SelectionChange(ByVal Target As Range)        Application.EnableEvents = False
    '◆ セル移動    If Target(1).Value = "▼" Then        Target(1).Offset(0, -1).Select    End If
    Application.EnableEvents = True
End Sub

セルを保護

Private Sub Worksheet_SelectionChange(ByVal Target As Range) '◆ セルを保護 Dim ProtectedCells As Range Set ProtectedCells = Range("AG6") If Not Application.Intersect(Target, ProtectedCells) Is Nothing Then MsgBox "このセルは編集できません。" Application.EnableEvents = False Target.Offset(0, 1).Select Application.EnableEvents = True End If
End Sub

＜検索＞

２つの検索ループ

Dim searchRange As RangeDim cell As RangeDim foundCell1 As RangeDim foundCell2 As RangeDim firstAddress1 As StringDim searchKey1 As StringDim searchKey2 As String
Set searchRange = s0_組織図.Range("G14:R" & lastRow)
If i = 116 Then Stop
searchKey1 = .Cells(i, d0_従業員名簿("姓")).ValueSet foundCell1 = searchRange.Find(what:=searchKey1, LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlByRows)If Not foundCell1 Is Nothing Then
firstAddress1 = foundCell1.Address Do Debug.Print i & Space(10) & .Cells(i, d0_従業員名簿("姓")).Value & vbTab & Space(10) & firstAddress1 & Space(10) & foundCell1.Address & Space(10) _ & .Cells(i, d0_従業員名簿("キーワード")).Value If Replace(Replace(s0_組織図.Cells(foundCell1.Row, 4).Value, " ", ""), "　", "") = .Cells(i, d0_従業員名簿("F部署")).Value Then If .Cells(i, d0_従業員名簿("キーワード")).Value <> "" Then searchKey2 = .Cells(i, d0_従業員名簿("キーワード")).Value Set foundCell2 = s0_組織図.Range("G" & foundCell1.Row & ":R" & foundCell1.Row).Find(what:=searchKey2, LookIn:=xlValues, lookat:=xlPart, _ SearchOrder:=xlByRows) If Not foundCell2 Is Nothing Then .Cells(i, d0_従業員名簿("Fグループ")).Value = s0_組織図.Cells(foundCell2.Row, 5).Value .Cells(i, d0_従業員名簿("Fグループ")).Interior.ColorIndex = 33 '青色 Exit Do End If Else .Cells(i, d0_従業員名簿("Fグループ")).Value = s0_組織図.Cells(foundCell1.Row, 5).Value .Cells(i, d0_従業員名簿("Fグループ")).Interior.ColorIndex = 33 '青色 Exit Do End If End If
Debug.Print Space(70) & searchRange.Address Set foundCell1 = searchRange.Find(what:=searchKey1, LookIn:=xlValues, lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ After:=foundCell1) If foundCell1 Is Nothing Then Exit Do ElseIf foundCell1.Address = firstAddress1 Then Exit Do End If Loop
End If

＜フォルダ＞

フォルダ_指定

Function f_フォルダ_指定(p_str As String) As Boolean
f_フォルダ_指定 = False
Dim folderDialog As fileDialog Dim folderExists As Boolean Dim selectedFolder As String Dim w_str As String Set folderDialog = Application.fileDialog(msoFileDialogFolderPicker) w_str = Range(p_str).Value On Error Resume Next folderExists = Dir(w_str, vbDirectory) <> "" On Error GoTo 0 If folderExists And w_str <> "" Then folderDialog.InitialFileName = Range(p_str).Value Else folderDialog.InitialFileName = ThisWorkbook.Path End If If Right(folderDialog.InitialFileName, 1) <> "\" Then folderDialog.InitialFileName = folderDialog.InitialFileName & "\" End If SendKeys "{HOME}" SendKeys "{END}" Application.DisplayAlerts = False If folderDialog.Show = -1 Then selectedFolder = folderDialog.SelectedItems(1) Worksheets("メニュー").Range(p_str).Value = selectedFolder '◆ 指定履歴追加 If f_指定履歴追加(selectedFolder, Range(p_str).Address) = False Then MsgBox "指定履歴の追加が、できませんでした。", vbOKOnly + vbExclamation, "指定履歴追加エラー" End If End If Application.DisplayAlerts = True Set folderDialog = Nothing f_フォルダ_指定 = True
End Function

フォルダ_開く

Function f_フォルダ_開く(p_str As String) As Boolean
f_フォルダ_開く = False Dim folderPath As String If Range(p_str).Value = "" Then Exit Function End If p_str = Range(p_str).Value If InStr(1, Mid(p_str, InStrRev(p_str, "\"), 99), ".") > 0 Then folderPath = Left(p_str, InStrRev(p_str, "\")) Else folderPath = p_str & "\" End If On Error Resume Next Shell "explorer.exe " & folderPath, vbNormalFocus If Err.Number <> 0 Then MsgBox "フォルダが開けません。ご確認下さい。", vbCritical, "開くエラー" Exit Function End If On Error GoTo 0
f_フォルダ_開く = True
End Function

＜ブック＞

ブックを指定する

Function f_ブックを指定する(p_str As String) As Boolean
    f_ブック_指定 = False
    Dim fileDialog As fileDialog    Dim w_str As String    Dim folderExists As Boolean    Dim selectedFile As String        Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)            w_str = Left(Range(p_str).Value, InStrRev(Range(p_str).Value, "\"))        On Error Resume Next    folderExists = Dir(w_str, vbDirectory) <> ""    On Error GoTo 0        If folderExists And w_str <> "" Then        fileDialog.InitialFileName = Range(p_str).Value    Else        fileDialog.InitialFileName = ThisWorkbook.Path & "\"    End If
    fileDialog.Filters.Clear    fileDialog.Filters.Add "All Files", "*.*"         Application.DisplayAlerts = False             ' ダイアログを表示     SendKeys "{HOME}"     SendKeys "{LEFT}"     SendKeys "{END}"     SendKeys "{HOME}"     SendKeys "{LEFT}"     SendKeys "{END}"     SendKeys "{HOME}"     SendKeys "{LEFT}"     SendKeys "{END}"     SendKeys "{HOME}"     SendKeys "{LEFT}"     SendKeys "{END}"     SendKeys "{HOME}"     SendKeys "{LEFT}"     SendKeys "{END}"     SendKeys "{HOME}"     SendKeys "{LEFT}"     SendKeys "{END}"
    If fileDialog.Show = -1 Then                selectedFile = fileDialog.SelectedItems(1)        Worksheets("メニュー").Range(p_str).Value = selectedFile                '◆ 指定履歴追加        If f_指定履歴追加(selectedFile, Range(p_str).Address) = False Then            MsgBox "指定履歴の追加が、できませんでした。", vbOKOnly + vbExclamation, "指定履歴追加エラー"        End If            Else                Application.DisplayAlerts = True        Exit Function            End If    Application.DisplayAlerts = True
    f_ブック_指定 = True
End Function

ブックを開く

Function f_ブックを開く(p_name As String) As Workbook
    Set f_ブック_開く = Nothing
    Dim wb As Workbook
    If Left(p_name, 1) = "_" Then        ThisWorkbook.Activate        p_name = Range(p_name).Value    End If
    On Error Resume Next    Set wb = Workbooks.Open(Filename:=p_name, ReadOnly:=True, UpdateLinks:=0)    If Err.Number <> 0 Then        MsgBox "ファイルが開けません。ご確認下さい。" & p_name, vbCritical, "ファイル開く"    End If    On Error GoTo 0
    Set f_ブック_開く = wb
End Function

Function f_ブックを開く_読み取り専用(p_name As String)
    Dim wb As Workbook        On Error Resume Next    Set wb = Workbooks.Open(Filename:=p_name, ReadOnly:=True, UpdateLinks:=0)    If Err.Number <> 0 Then        MsgBox "ファイルが開けません。ご確認下さい。", vbCritical, "開くエラー"    End If    On Error GoTo 0
End Function
Function f_ブックを開く_編集可(p_name As String)
    Dim wb As Workbook        On Error Resume Next    Set wb = Workbooks.Open(Filename:=p_name, UpdateLinks:=0)    If Err.Number <> 0 Then        MsgBox "ファイルが開けません。ご確認下さい。", vbCritical, "開くエラー"    End If    On Error GoTo 0
End Function

ブックを開く_パスワード付き

Function f_ブックを開く_パスワード付き(p_name As String, p_pass As String) As Workbook
    Set f_ブック_開く_パスワード付き = Nothing
    Dim wb As Workbook
    On Error Resume Next    Set wb = Workbooks.Open(Filename:=p_name, password:=p_pass, ReadOnly:=True, UpdateLinks:=0)    On Error GoTo 0
    Set f_ブック_開く_パスワード付き = wb
End Function

ファイル_開く_セキュリティレベル保持

Function f_ファイルを開く_セキュリティレベル保持(p_name As String)
Dim wb As Workbook On Error Resume Next Application.AutomationSecurity = msoAutomationSecurityForceDisable Set wb = Workbooks.Open(Filename:=p_name, ReadOnly:=True, UpdateLinks:=0) Application.AutomationSecurity = msoAutomationSecurityByUI If Err.Number <> 0 Then MsgBox "ファイルが開けません。ご確認下さい。", vbCritical, "開くエラー" End If On Error GoTo 0
End Function

＜履歴＞

指定履歴追加

Function f_指定履歴追加(p_path As String, p_address As String) As Boolean
    f_指定履歴追加 = False
    Dim ws As Worksheet    Dim searchRange As Range    Dim searchValue As String    Dim foundCell As Range        If p_path = "" Then        f_指定履歴追加 = True        Exit Function    End If
    Set ws = ThisWorkbook.Worksheets("指定履歴")    Set searchRange = ws.Cells        searchValue = p_path    Set foundCell = searchRange.Find(what:=searchValue, LookIn:=xlValues, lookat:=xlWhole)        If Not foundCell Is Nothing Then        ws.Range(foundCell.Address).Delete Shift:=xlUp    End If
    Select Case p_address    Case Range("_原紙フォルダ").Address        ws.Range("A1").Insert Shift:=xlDown        ws.Range("A1").Value = p_path    Case Range("_組織図").Address        ws.Range("B1").Insert Shift:=xlDown        ws.Range("B1").Value = p_path    Case Range("_従業員名簿").Address        ws.Range("C1").Insert Shift:=xlDown        ws.Range("C1").Value = p_path    End Select        ws.Cells.EntireColumn.AutoFit        f_指定履歴追加 = True
End Function

＜シート＞

シート設定

Function f_シート設定()
Set s0_メニュー = Worksheets("メニュー") Set s0_フォルダ一覧 = Worksheets("フォルダ一覧") On Error Resume Next Set s0_組織図 = Worksheets("組織図") On Error GoTo 0 Set s0_ファイル名変更 = Worksheets("ファイル名変更") Set s0_原紙一覧 = Worksheets("原紙一覧") Set s0_従業員名簿 = Worksheets("従業員名簿")
End Function

＜位置＞

カーソル位置

With ws .Activate .Range("A1").SelectEnd With
With ActiveWindow .ScrollRow = Range("A1").Row .ScrollColumn = Range("A1").ColumnEnd With

列位置設定

'◆ 連想配列Public d0_従業員名簿 As VariantPublic d0_従業員名簿x As Variant
Function f_列位置設定_従業員名簿()
    Dim j As Integer    Dim r As Integer
    '◆ 連想配列    Set d0_従業員名簿 = CreateObject("Scripting.Dictionary")    Set d0_従業員名簿x = CreateObject("Scripting.Dictionary")
    r = 2
    With s0_従業員名簿
        For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column            If .Cells(r, j).Value <> "" Then                d0_従業員名簿.Add Replace(CStr(.Cells(r, j).Value), Chr(10), ""), .Cells(r, j).Column                d0_従業員名簿x.Add Replace(CStr(.Cells(r, j).Value), Chr(10), ""), Split(.Cells(r, j).Address, "$")(1)            End If        Next j            End With
    Dim key As Variant    Debug.Print "------------------------------"    Debug.Print "d0_従業員名簿"    For Each key In d0_従業員名簿.Keys        Debug.Print d0_従業員名簿(key) & vbTab & key        Debug.Print Space(50) & d0_従業員名簿x(key) & vbTab & key    Next key    Debug.Print "------------------------------"
End Function

列位置設定

Function f_列位置設定_フォルダ一覧()
    Dim j As Integer    Dim w_col As Integer    Dim w_str As String
    Set d0_フォルダ一覧 = CreateObject("Scripting.Dictionary")    Set d0_フォルダ一覧x = CreateObject("Scripting.Dictionary")
    With s0_フォルダ一覧
        For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column            If .Cells(1, j).Value <> "" Then                            w_col = InStr(1, .Cells(1, j).Value, "（")                If w_col > 0 Then                    w_str = Left(.Cells(1, j).Value, w_col - 1)                Else                    w_str = .Cells(1, j).Value                End If                                d0_フォルダ一覧.Add Replace(w_str, Chr(10), ""), .Cells(1, j).Column                d0_フォルダ一覧x.Add Replace(CStr(.Cells(1, j).Value), Chr(10), ""), Split(.Cells(1, j).Address, "$")(1)                        End If        Next j            End With
' Dim key As Variant' Debug.Print "------------------------------"' Debug.Print "d0_フォルダ一覧"' For Each key In d0_フォルダ一覧.Keys' Debug.Print d0_フォルダ一覧(key) & vbTab & key' Debug.Print Space(50) & d0_フォルダ一覧x(key) & vbTab & key' Next key' Debug.Print "------------------------------"
End Function

列位置設定

Public s_原紙振分け As WorksheetPublic d_原紙振分け As ObjectPublic d_原紙振分けx As Object
Function f_列位置設定_原紙振分け()
    Dim j As Integer
    Set s_原紙振分け = Worksheets("原紙振分け")    Set d_原紙振分け = CreateObject("Scripting.Dictionary")    Set d_原紙振分けx = CreateObject("Scripting.Dictionary")
    With s_原紙振分け
        For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column            If .Cells(1, j).Value <> "" Then                d_原紙振分け.Add Replace(CStr(.Cells(1, j).Value), vbLf, ""), .Cells(1, j).Column                d_原紙振分けx.Add Replace(CStr(.Cells(1, j).Value), vbLf, ""), Split(.Cells(1, j).Address, "$")(1)            End If        Next j            End With
' Dim key As Variant' Debug.Print "------------------------------"' Debug.Print "d_原紙振分け"' For Each key In d_原紙振分け.Keys' Debug.Print Space(20) & d_原紙振分け(key) & vbTab & key' Next key' Debug.Print "------------------------------"' Debug.Print "d_原紙振分けx"' For Each key In d_原紙振分けx.Keys' Debug.Print Space(20) & d_原紙振分けx(key) & vbTab & key' Next key' Debug.Print "------------------------------"
End Function

列位置設定

Public s_原紙振分け As WorksheetPublic d_原紙振分け As ObjectPublic d_原紙振分けx As Object
Function f_列位置設定_原紙振分け()
    Dim j As Integer
    Set s_原紙振分け = Worksheets("原紙振分け")    Set d_原紙振分け = CreateObject("Scripting.Dictionary")    Set d_原紙振分けx = CreateObject("Scripting.Dictionary")
    With s_原紙振分け
        For j = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column            If .Cells(1, j).Value <> "" Then                d_原紙振分け.Add Replace(CStr(.Cells(1, j).Value), vbLf, ""), .Cells(1, j).Column                d_原紙振分けx.Add Replace(CStr(.Cells(1, j).Value), vbLf, ""), Split(.Cells(1, j).Address, "$")(1)            End If        Next j            End With
' Dim key As Variant' Debug.Print "------------------------------"' Debug.Print "d_原紙振分け"' For Each key In d_原紙振分け.Keys' Debug.Print Space(20) & d_原紙振分け(key) & vbTab & key' Next key' Debug.Print "------------------------------"' Debug.Print "d_原紙振分けx"' For Each key In d_原紙振分けx.Keys' Debug.Print Space(20) & d_原紙振分けx(key) & vbTab & key' Next key' Debug.Print "------------------------------"
End Function

＜入力規則＞

選択セル

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Cells(1, Target.Column).Value = "氏名" Then
        Call f_シート設定_評価集計        Call f_列位置設定_従業員名簿
        '■■■■■■■■■■■■■■■■■■        Application.EnableEvents = False        Application.ScreenUpdating = False        '■■■■■■■■■■■■■■■■■■                Call f_グループ選択(Target, Cells(Target.Row, d0_従業員名簿("F部署")), Cells(Target.Row, d0_従業員名簿("Fグループ")))            Columns(Target.Column).AutoFit                '■■■■■■■■■■■■■■■■■■        Application.EnableEvents = True        Application.ScreenUpdating = True        '■■■■■■■■■■■■■■■■■■
    End If
End Sub

＜日時＞

処理年月編集

Function f_処理年月編集()
Dim w_年 As String Dim w_月 As String Dim w_col1 As Integer Dim w_col2 As Integer w_col1 = InStrRev(Range("_②「TMC報告書」先月").Value, "年") w_col2 = InStrRev(Range("_②「TMC報告書」先月").Value, "月") w_年 = Mid(Range("_②「TMC報告書」先月").Value, w_col1 - 4, 4) w_月 = Mid(Range("_②「TMC報告書」先月").Value, w_col1 + 1, w_col2 - w_col1 - 1) If 1 <= w_月 And w_月 <= 11 Then w_月 = w_月 + 1 ElseIf w_月 = 12 Then w_月 = 1 w_年 = w_年 + 1 End If Range("_処理年").Value = w_年 Range("_処理月").Value = w_月
End Function

＜その他＞

開始、終了

Sub フォルダ作成_Click()
    Debug.Print "============================================"
    '■■■■■■■■■■■■■■■■■    Application.ScreenUpdating = False    Application.DisplayAlerts = False    '■■■■■■■■■■■■■■■■■
    Call f_シート設定    Call f_列位置設定_フォルダ作成    Call f_フォルダ作成_Click
    '■■■■■■■■■■■■■■■■■    Application.DisplayAlerts = True    Application.ScreenUpdating = True    Application.StatusBar = False    '■■■■■■■■■■■■■■■■■
    With s_フォルダ作成        .Activate        .Range("A1").Select        .Cells.EntireColumn.AutoFit    End With        With ActiveWindow        .ScrollRow = Range("A1").Row        .ScrollColumn = Range("A1").Column    End With
    MsgBox "終了しました。", vbInformation, "フォルダ作成"
End Sub

ウインドウ枠の固定

'◆ ウインドウ枠の固定On Error Resume Next
If ActiveWindow.FreezePanes Then    ActiveWindow.FreezePanes = FalseEnd If
.Range("A1").Select
With ActiveWindow    .ScrollRow = Range("A1").Row    .ScrollColumn = Range("A1").ColumnEnd With
If Left(.Name, 5) = "職能要件表" Then    .Rows(5).Select    ActiveWindow.FreezePanes = TrueElseIf Left(.Name, 5) = "能力評価表" Then    .Rows(8).Select    ActiveWindow.FreezePanes = TrueEnd If
On Error GoTo 0

入力規則

'◆ 入力規則With .Cells.Validation
.Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="テクマック事業部,営業部,管理部,樹脂加工部,生産管理部" .IgnoreBlank = True .InCellDropdown = True
End With

セル範囲選択

Range("A1:b10").Select Range("A1,b10").Select Range("A1", "b10").Select

SendKeys

Public Function SendKeys(InpKeys As String, Optional Wait As Boolean = False)
Static WSH As Object If WSH Is Nothing Then Set WSH = CreateObject("WScript.Shell") End If WSH.SendKeys InpKeys
End Function

最初のセル、最後のセル

    Dim firstRow As Long    Dim firstCol As Long
    ' 最初の行を取得    firstRow = ActiveSheet.Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:= _        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).row
    ' 最初の列を取得    firstCol = ActiveSheet.Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:= _        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
    ' 最初の行と列の交点のセルを選択    ActiveSheet.Cells(firstRow, firstCol).Select
    Dim lastRow As Long    Dim lastCol As Long
    ' 最後の行を取得    lastRow = ActiveSheet.Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:= _        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).row
    ' 最後の列を取得    lastCol = ActiveSheet.Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:= _        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
    ' 最後の行と列の交点のセルを選択    ActiveSheet.Cells(lastRow, lastCol).Select

空白で位置を合わせる

Space(20 - LenB(StrConv(h0_評価一覧(i, d0_評価一覧("対象")), vbFromUnicode)))

AutoFilterMode

ActiveSheet.ListObjects(1).ShowAutoFilter = False
If ActiveSheet.AutoFilterMode Then MsgBox "フィルターが設定されています"Else MsgBox "フィルターが設定されていません"End If
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllDataElse ActiveSheet.AutoFilterMode = FalseEnd If

セルが左上に来るように表示する

With ActiveWindow .ScrollRow = Range("C3").Row .ScrollColumn = Range("C3").Column End With

ソート

        '◆ ソート        With s0_給与情報.Sort
            .SortFields.Clear
            .SortFields.Add key:=s0_給与情報.Columns(d0_給与情報("長さ")), Order:=xlDescending            .SortFields.Add key:=s0_給与情報.Columns(d0_給与情報("氏名")), Order:=xlAscending                        .SetRange s0_給与情報.Cells            .Header = xlYes            .MatchCase = False            .Orientation = xlTopToBottom            .SortMethod = xlPinYin            .Apply
        End With
        '◆ ソート        With tbl.Sort            .SortFields.Clear            .SortFields.Add key:=tbl.ListColumns("所属").Range, Order:=xlAscending            .SortFields.Add key:=tbl.ListColumns("入社年月日").Range, Order:=xlAscending            .Header = xlYes            .Apply        End With

条件付き書式設定

With Worksheets("原紙一覧")        .Cells.FormatConditions.Delete        cx1 = Split(.Rows(1).Find(what:="種類", lookat:=xlWhole).Address, "$")(1)    cx2 = Split(.Rows(1).Find(what:="部署", lookat:=xlWhole).Address, "$")(1)
    With .UsedRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=$" & cx1 & "1<>$" & cx1 & "2")        .StopIfTrue = False        With .Borders(xlBottom)            .LineStyle = xlContinuous            .TintAndShade = 0            .Weight = xlThin            .ColorIndex = 3 '赤色        End With    End With        With .UsedRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=$" & cx2 & "1<>$" & cx2 & "2")        .StopIfTrue = False        With .Borders(xlBottom)            .LineStyle = xlContinuous            .TintAndShade = 0            .Weight = xlThin            .ColorIndex = 3 '赤色        End With    End With        .Columns(1).FormatConditions.Delete
End With
'◆ 「PW」が『(PW)』の時With .Range(d0_ファイル一覧x("種類1") & "1:" & .Cells.SpecialCells(xlCellTypeLastCell).Address).FormatConditions.Add(Type:=xlExpression, Formula1:="=$" & d0_ファイル一覧x("PW") & "1=""(PW)""")    .StopIfTrue = False    With .Interior        .ColorIndex = 3 '赤色    End With    With .Borders(xlEdgeRight)        .ColorIndex = 3 '赤色    End With    With .Borders(xlEdgeBottom)        .ColorIndex = 3 '赤色    End WithEnd With
'◆ 「除く」列With .UsedRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=left(A$1,2)=""除く""")    .StopIfTrue = False    With .Interior        .ColorIndex = 3 '赤色    End With    With .Borders(xlEdgeRight)        .ColorIndex = 3 '赤色    End WithEnd With

'◆ ヘッダの罫線With .UsedRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=row()=1")    With .Borders(xlEdgeLeft)        .ColorIndex = 1 '黒色        .TintAndShade = 0    End With    With .Borders(xlEdgeRight)        .ColorIndex = 1 '黒色        .TintAndShade = 0    End WithEnd With
'◆ 条件付き書式設定Dim d_str1 As StringDim d_str2 As String
With Worksheets("原紙コピー")
    .Cells.FormatConditions.Delete        d_str1 = Split(.Rows(1).Find(what:="結果", lookat:=xlWhole).Address, "$")(1)    d_str2 = Split(.Rows(1).Find(what:="氏名", lookat:=xlWhole).Address, "$")(1)        With .Columns(d_str1 & ":" & d_str2).FormatConditions.Add(Type:=xlExpression, Formula1:="=$" & d_str1 & "1=""済""")        .Interior.ColorIndex = 15    End With
    With .Columns(d_str1 & ":" & d_str2).FormatConditions.Add(Type:=xlExpression, Formula1:="=and($" & d_str1 & "1="""",$" & d_str2 & "1<>""""")        .Interior.ColorIndex = 6    End With
    d_str1 = Split(.Rows(1).Find(what:="種類", lookat:=xlWhole).Address, "$")(1)        With .UsedRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=$" & d_str1 & "1=""原紙""")        .Interior.ColorIndex = 20    End With
    d_str1 = Split(.Rows(1).Find(what:="種類", lookat:=xlWhole).Address, "$")(1)        With .UsedRange.FormatConditions.Add(Type:=xlExpression, Formula1:="=$" & d_str1 & "1=""コピー先""")        .Interior.ColorIndex = 20    End With
End With

ブックを閉じる

'◆ ブックを閉じる wb.Close SaveChanges:=False

グループを表示する

On Error Resume Next With s0d_ファイル一覧 For w_int = 1 To .Columns.Count If .Columns(w_int).EntireColumn.OutlineLevel > 1 Then .Columns(w_int).EntireColumn.ShowDetail = True End If Next w_int End With On Error GoTo 0

列番号をアルファベットに変換

Cells(1, 1).Value = Cells(1, 5).Address Cells(2, 1).Value = Split(Cells(1, 5).Address, "$")(0) Cells(3, 1).Value = Split(Cells(1, 5).Address, "$")(1) Cells(4, 1).Value = Split(Cells(1, 5).Address, "$")(2)

ファイルフィルタ

    ' 初期表示    fileDialog.InitialFileName = Range("_aaa").Value
    ' ファイルフィルタを設定    fileDialog.Filters.Clear    fileDialog.Filters.Add "All Files", "*.*"' fileDialog.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"            ' ダイアログを表示    SendKeys "{HOME}"    SendKeys "{END}"    Application.DisplayAlerts = False    If fileDialog.Show = -1 Then                selectedFile = fileDialog.SelectedItems(1)
    Else                Application.DisplayAlerts = True        Exit Function        End If    Application.DisplayAlerts = True

列複写

s1.Columns(j - 1).Copy Destination:=s.Columns(j)

行挿入

s.Columns(1).Insert Shift:=xlToRight

列削除

s1_提出用.Columns(c_総合計 - 1).Delete

シート削除

Sub DeleteSheet() Dim ws As Worksheet
' 削除したいシート名を指定 Set ws = ThisWorkbook.Worksheets("Sheet1") ' 削除前に警告ダイアログを非表示にする Application.DisplayAlerts = False ' シートを削除 ws.Delete ' 警告ダイアログを再表示 Application.DisplayAlerts = TrueEnd Sub

使用範囲

Range("A1", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).Select Range("A1", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).Row Range("A1", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).Column
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
s.UsedRange.Cells(s.UsedRange.Cells.Count).Rows.UsedRange.Cells(s.UsedRange.Cells.Count).Column
h_配列 = s1.Range("A1", s1.UsedRange.Cells(s1.UsedRange.Cells.Count)).Values1.Range("A1", s1.Cells(UBound(h_配列, 1), UBound(h_配列, 2))).Value = h_配列
h_配列 = s1.Range("A1", s1.UsedRange.Cells(s1.UsedRange.Cells.Count)).Formulas1.Range("A1", s1.Cells(UBound(h_配列, 1), UBound(h_配列, 2))).Formula = h_配列

全表示

If s1.AutoFilterMode Then If s1.FilterMode Then s1.ShowAllData End If End If

Debug.Print

Debug.Print "===========================================================" Dim w_step As Integer Dim w_timer As Single w_step = 1 w_timer = Timer Debug.Print "★" & w_step & " " & Int(Timer - w_timer) & "秒": w_timer = Timer: w_step = w_step + 1 Debug.Print "☆" & w_step & " " & Int(Timer - w_timer) & "秒": w_timer = Timer: w_step = w_step + 1

配列（値）

Public h_配列 As VariantPublic i_配列 As Long, j_配列 As Long

    配列 = ActiveSheet.UsedRange.Value
    For i_配列 = LBound(配列, 1) To UBound(配列, 1)        For j_配列 = LBound(配列, 2) To UBound(配列, 2)
            If 配列(i_配列, j_配列) <> "" Then                配列(i_配列, j_配列) = StrConv(配列(i_配列, j_配列), vbNarrow)            End If
        Next j_配列    Next i_配列
    ActiveSheet.UsedRange.Value = 配列

配列（式）

Sub GetFormulasToArray()    Dim ws As Worksheet    Dim rng As Range    Dim formulaArray As Variant
    ' ワークシートと範囲を設定    Set ws = ThisWorkbook.Sheets("Sheet1")    Set rng = ws.Range("A1:B10")
    ' 範囲の数式を配列に取り込む    formulaArray = rng.Formula
    ' 配列の内容を確認（例としてイミディエイトウィンドウに出力）    Dim i As Long, j As Long    For i = LBound(formulaArray, 1) To UBound(formulaArray, 1)        For j = LBound(formulaArray, 2) To UBound(formulaArray, 2)            Debug.Print formulaArray(i, j)        Next j    Next iEnd Sub