1234578
anonymous No title
VBA
’フォームモジュール

Option Explicit

Public Enum e_MB_ButtonOption
    mbOKOnly = 0
    mbOKCancel
    mbAbortRetryIgnore
    mbYesNoCancel
    mbYesNo
    mbRetryCancel
    mbOneTwoThree
End Enum

Private g_Rtn_MsgBox As Long

Public Enum e_Rtn_Msgbox
    RtnButton1 = 1
    RtnButton2
    RtnButton3
End Enum



Function MsgBoxShow( _
                            ByVal Prompt As String, _
            Optional ByVal Button_Option As Long, _
          Optional ByVal Button1_Caption As String, _
          Optional ByVal Button2_Caption As String, _
          Optional ByVal Button3_Caption As String, _
                    Optional ByVal Title As String, _
          Optional ByVal Prompt_FontSize As Long = 11, _
          Optional ByVal Button_FontSize As Long = 11) As Long
    
    
    
    If Button1_Caption = "" And Button2_Caption = "" And Button3_Caption = "" Then
        Select Case Button_Option
            Case mbOKOnly
                Button1_Caption = "OK"
                Button2_Caption = ""
                Button3_Caption = ""
            Case mbOKCancel
                Button1_Caption = "OK"
                Button2_Caption = "キャンセル"
                Button3_Caption = ""
            Case mbAbortRetryIgnore
                Button1_Caption = "中止"
                Button2_Caption = "再試行"
                Button3_Caption = "無視"
            Case mbYesNoCancel
                Button1_Caption = "はい"
                Button2_Caption = "いいえ"
                Button3_Caption = "キャンセル"
            Case mbYesNo
                Button1_Caption = "はい"
                Button2_Caption = "いいえ"
                Button3_Caption = ""
            Case mbRetryCancel
                Button1_Caption = "再試行"
                Button2_Caption = "キャンセル"
                Button3_Caption = ""
            Case mbOneTwoThree
                Button1_Caption = "1"
                Button2_Caption = "2"
                Button3_Caption = "3"
        End Select
    End If
    
    
    
    Me.Caption = Title
    Me.lbl_Prompt.Caption = Prompt
    Me.Button1.Caption = Button1_Caption
    Me.Button2.Caption = Button2_Caption
    Me.Button3.Caption = Button3_Caption
    Me.lbl_Prompt.Font.Size = Prompt_FontSize
    
    
    Me.lbl_Prompt.AutoSize = True
    
    Dim CurrentControl As Control   'ループ用変数
    For Each CurrentControl In Me.Controls 'コントロールをループ
        If TypeName(CurrentControl) = "CommandButton" Then  'コマンドボタンのみ対象
            If CurrentControl.Caption = "" Then CurrentControl.Visible = False  'ボタンが空白だったら非表示にする
            CurrentControl.Font.Size = Button_FontSize      'ボタンのフォントサイズを設定
            CurrentControl.AutoSize = True                  'ボタンのサイズを自動設定
            CurrentControl.Top = Me.lbl_Prompt.Height + 40  'ラベルとボタンの間にすき間をいれる
        End If
    Next
    
    Me.Button2.Left = Me.Button1.Left + Me.Button1.Width + 10   'ボタン1とボタン2の間にすき間を入れる
    Me.Button3.Left = Me.Button2.Left + Me.Button2.Width + 10   'ボタン2とボタン3の間にすき間を入れる
    
    'ユーザーフォームのサイズを設定する
    Me.Height = Me.lbl_Prompt.Height + Me.Button1.Height + 80
    Me.Width = WorksheetFunction.Max(Me.lbl_Prompt.Width + 20, Me.Button1.Width + Me.Button2.Width + Me.Button3.Width + 100)

    Me.Show
    
    
    
    MsgBoxShow = g_Rtn_MsgBox
    g_Rtn_MsgBox = 0
End Function



Private Sub Button1_Click()
    g_Rtn_MsgBox = RtnButton1
    Unload Me
End Sub


Private Sub Button2_Click()
    g_Rtn_MsgBox = RtnButton2
    Unload Me
End Sub

Private Sub Button3_Click()
    g_Rtn_MsgBox = RtnButton3
    Unload Me
End Sub





’標準モジュール

Sub Sample()

    Dim Rtn As Long
    Rtn = Form_MsgBox.MsgBoxShow(Prompt:="マクロを実行しますか?", _
                                 Button_Option:=mbOKCancel, _
                                 Title:="実行確認", _
                                 Prompt_FontSize:=30, _
                                 Button_FontSize:=25)
    
    Select Case Rtn
        Case RtnButton1:    Form_MsgBox.MsgBoxShow Prompt:="処理を開始します。", Prompt_FontSize:=20, Button_FontSize:=25
        Case RtnButton2:    Form_MsgBox.MsgBoxShow Prompt:="処理を中止します。", Prompt_FontSize:=40, Button_FontSize:=25:    Exit Sub
        Case Else:          Form_MsgBox.MsgBoxShow Prompt:="処理を中止します。", Prompt_FontSize:=40, Button_FontSize:=25:    Exit Sub
    End Select
    
End Sub
anonymous 指定列毎に転記
VBA
Sub 指定列毎に転記()
    
    Dim ws1         As Worksheet:   Set ws1 = Worksheets(1)
    Dim ws2         As Worksheet:   Set ws2 = Worksheets(2)
    
    Dim 列数        As Long:        列数 = Names("列数").RefersToRange.Value
    Dim 行数        As Long:        行数 = Names("行数").RefersToRange.Value
    Dim ヘッダー数  As Long:        ヘッダー数 = Names("ヘッダー数").RefersToRange.Value
    
    Dim 最終行      As Long:        最終行 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Dim 回数        As Long:        回数 = WorksheetFunction.RoundUp((最終行 - ヘッダー数) / 行数, 0)
    
    Dim 記録行      As Long:        記録行 = ヘッダー数 + 1
    Dim 転記列      As Long:        転記列 = 2
    
    Dim i           As Long
    For i = 1 To 回数
        ws1.Cells(1, 1).Resize(ヘッダー数, 列数).Copy ws2.Cells(1, 転記列)
        ws1.Cells(記録行, 1).Resize(行数, 列数).Copy ws2.Cells(ヘッダー数 + 1, 転記列)
        記録行 = 記録行 + 行数
        転記列 = 転記列 + 列数 + 2
    Next
    
End Sub
anonymous No title
VBA
With ws調整シート

    .Range(.Rows(R1st調整範囲), .Rows(RLast調整範囲)).AutoFit
    
    Dim R As Long
    For R = R1st調整範囲 To RLast調整範囲
        .Rows(R).RowHeight = WorksheetFunction.MIN _
            (.Rows(R).RowHeight, 最大行高)
    Next
    
End With
anonymous No title
VBA
Private Sub VBA100Answer004()

Dim ws As Worksheet: Set ws = ActiveSheet
Dim lastrow As Long: lastrow = Cells(Rows.Count, 1).End(xlUp).Row  '最終行
Dim lastcol As Long: lastcol = Cells(1, Columns.Count).End(xlToLeft).Column  '最終列

'最終行と最終列を取得
'B2を起点にする
'最終行と最終列には数式が入っているのでマイナス1する

ws.Range(Cells(2, 2), Cells(lastrow - 1, lastcol - 1)).ClearContents

End Sub
anonymous セミオートログイン Ver.2
VBA
Option Explicit

Sub リンク作成()
    
    Dim i As Long
    For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row
        Hyperlinks.Add anchor:=Cells(i, 3), Address:="", SubAddress:="", TextToDisplay:="実行"
    Next
    
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    
    Dim ジャンル As String
    ジャンル = Target.Range.Offset(0, 1).Value
    
    Dim 最初のセル As Range
    Set 最初のセル = Target.Range.Offset(0, 2)
    
    Select Case ジャンル
        Case "フォルダ"
            Call フォルダ(最初のセル)
        Case "Zoom"
            Call Zoom(最初のセル)
    End Select
    
End Sub

Sub フォルダ(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "*無題 - メモ帳"
    Call ySendKeys("^V")
    Call ySendKeys("{TAB}")
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    Call ySendKeys("^V")
    Call ySendKeys(" ")
    Call ySendKeys("{TAB}")
    
    Application.CutCopyMode = False
    
End Sub

Sub Zoom(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "Zoom"
    Call ySendKeys("^V")
    Call ySendKeys("{TAB}{TAB}{TAB}{TAB}")
    Call ySendKeys(" ")
    Call ySendKeys("{TAB}")
    Call ySendKeys(" ", 2)                          '2秒とめる
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    AppActivate "ミーティングパスコードを入力"
    Call ySendKeys("^V")
    Call ySendKeys("{TAB}")
    Call ySendKeys(" ", 5)                          '5秒とめる
    
    Call ySendKeys(" ")
    
    Application.CutCopyMode = False
    
End Sub

Private Function ySendKeys(Keys As String, Optional Time As Double = 0.5, Optional Wait As Boolean = True)
    
    Call Application.SendKeys(Keys, Wait)
    Call Application.Wait([Now()] + Time / 86400)
    
End Function
anonymous セミオートログイン
VBA
Option Explicit

Sub リンク作成()
    
    Dim i As Long
    
    For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row
        Hyperlinks.Add anchor:=Cells(i, 3), Address:="", SubAddress:="", TextToDisplay:="実行"
    Next
    
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    
    Dim ジャンル As String
    ジャンル = Target.Range.Offset(0, 1).Value
    
    Dim 最初のセル As Range
    Set 最初のセル = Target.Range.Offset(0, 2)
    
    Select Case ジャンル
        Case "フォルダ"
            Call フォルダ(最初のセル)
        Case "Zoom"
            Call Zoom(最初のセル)
    End Select
    
End Sub

Sub フォルダ(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "エクスプローラ":                   Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{ENTER}", True
    
    Application.CutCopyMode = False
    
End Sub

Sub Zoom(ByVal セル As Range)
    
    Rem コピー1
    セル.Copy
    AppActivate "Zoom":                             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    
    Application.Wait [Now() + "00:00:02"]           '2秒とめる(PW画面に移るまで時間かかるため)
    
    Rem コピー2
    セル.Offset(0, 1).Copy
    AppActivate "ミーティングパスコードを入力":     Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "^V", True:                Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys "{TAB}", True:             Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    Application.SendKeys " ", True:                 Application.Wait [Now() + "00:00:00.5"]         '0.5秒とめる
    
    Application.Wait [Now() + "00:00:05"]           '5秒とめる(接続に時間がかかるため)
    
    Application.SendKeys " ", True
    
    Application.CutCopyMode = False
    
End Sub
anonymous コピー&リネーム
VBA
Option Explicit
Const フォルダパスの行数 = 3
Const 元の列数 = 2
Const コピー先の列数 = 3
Const 最初の行 = 6

Sub リネーム()
    
    Dim ws作業シート As Worksheet
    Set ws作業シート = ThisWorkbook.ActiveSheet
    
    Rem コピー先の指定がなければフォルダを作成
    If ws作業シート.Cells(フォルダパスの行数, コピー先の列数) = "" Then
        MkDir ws作業シート.Cells(フォルダパスの行数, 元の列数) & "\リネーム後"
        ws作業シート.Cells(フォルダパスの行数, コピー先の列数) = ws作業シート.Cells(フォルダパスの行数, 元の列数) & "\リネーム後"
    End If
    
    Dim 最後の行 As Long
    最後の行 = ws作業シート.Cells(Rows.Count, 元の列数).End(xlUp).Row
    
    Rem コピー&リネーム
    Dim f As Long
    For f = 最初の行 To 最後の行
        FileCopy ws作業シート.Cells(フォルダパスの行数, 元の列数).Value & "\" & ws作業シート.Cells(f, 元の列数).Value, _
                 ws作業シート.Cells(フォルダパスの行数, コピー先の列数).Value & "\" & ws作業シート.Cells(f, コピー先の列数).Value
    Next
    
    MsgBox "コピー&リネーム完了!"
    
End Sub
anonymous ブックシートの保護と解除
VBA
Sub 全シートの保護と解除()
    
選択:
    
    Rem 保護の設定・解除の選択
    Dim 選択 As Long
    選択 = Application.InputBox(Prompt:="処理を選択してください" & vbCrLf & vbCrLf & " 1 = 保護   2 = 解除   0 = キャンセル", Type:=1)
    
    Rem キャンセルと再選択
    If 選択 = False Then GoTo キャンセル処理
    If Not (選択 = 1 Or 選択 = 2) Then
        MsgBox "1 か 2 を入力してください"
        GoTo 選択
    End If
    
    Rem パスワードの入力
    Dim GetPW As String
    Select Case 選択
        Case 1
            GetPW = Application.InputBox(Prompt:="保護パスワードを入力してください", Type:=2)
            If GetPW = False Then GoTo キャンセル処理
            Call 保護(GetPW)
        Case 2
            GetPW = Application.InputBox(Prompt:="解除パスワードを入力してください", Type:=2)
            If GetPW = False Then GoTo キャンセル処理
            Call 保護解除(GetPW)
    End Select
    
    Exit Sub
    
キャンセル処理:
    MsgBox "キャンセルしました"
    
End Sub

Sub 保護(ByVal PW As String)
    
    Rem シートの保護
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Protect Password:=PW, UserInterfaceOnly:=True     'マクロでの操作は許可
    Next
    
    Rem ブックの保護
    ActiveWorkbook.Protect Password:=PW, Structure:=True, Windows:=False
    
End Sub

Sub 保護解除(ByVal PW As String)
    
    Rem シートの保護解除
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Unprotect Password:=PW
    Next
    
    Rem ブックの保護解除
    ActiveWorkbook.Unprotect Password:=PW
    
End Sub
anonymous ブックとシートの保護
VBA
Sub 全シートの保護と解除()
    
    On Error GoTo キャンセル処理
    
    Rem 保護の設定・解除の選択
    Dim 選択 As Long
    選択 = InputBox("処理を選択してください" & vbCrLf & vbCrLf & "保護 = 1  解除 = 2")
    
    On Error GoTo 0
    
    Rem パスワードの入力
    Dim GetPW As String
    GetPW = InputBox("パスワードを入力してください")
    
    Select Case 選択
        Case 1
            Call 保護(GetPW)
        Case 2
            Call 保護解除(GetPW)
    End Select
    
    Exit Sub
    
キャンセル処理:
    MsgBox "キャンセルしました"
    
End Sub

Sub 保護(ByVal PW As String)
    
    Rem シートの保護
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Protect Password:=PW, UserInterfaceOnly:=True     'マクロでの操作は許可
    Next
    
    Rem ブックの保護
    ActiveWorkbook.Protect Password:=PW, Structure:=True, Windows:=False
    
End Sub

Sub 保護解除(ByVal PW As String)
    
    Rem シートの保護解除
    Dim ws As Worksheet
    For Each ws In Worksheets
        ws.Unprotect Password:=PW
    Next
    
    Rem ブックの保護解除
    ActiveWorkbook.Unprotect Password:=PW
    
End Sub
anonymous 処理時間の計測
VBA
Sub 処理時間計測()
    
    Rem 計測開始
    Dim 開始時間 As Single
    開始時間 = Timer
    
    Rem 計測終了
    Dim 終了時間 As Single
    終了時間 = Timer
    
    MsgBox "完了!" & vbCrLf & vbCrLf & "処理時間:" & Round(終了時間 - 開始時間, 2) & "秒"
    
End Sub
Don't you submit code?
Submit
1234578