[[20180105233753]]　『ユーザーフォームボタンクリック後、人によるセメx（なか）　ページの最後に飛ぶ

『ユーザーフォームボタンクリック後、人によるセルの選択、その内容をファームに返す方法』（なか）

シート内に上段に品物、Ａ列に日付があり。
その品物と日付が、交わるところに名前を入れる貸し出し表を作成してます。
予約、貸出はボタンから自動で名前が入るように作れたのですが、取消ボタンを作りたくおもっています。
イメージとしては、ユーザーフォームにて取消ボタンをクリックすると、メッセージボックスで、取り消したい日にちと品物の名前を選択とでるので、シート内の取り消したい日付と品物が交わる名前を、クリックするとその日付と品物がユーザーフォームに帰ってきて、確認後、取消実行ボタンで、名前を消す作業をしたく思ってます。

途中で人の介入をいれるということができるのでしょうか？

いつでもそのセルをクリックしたらマクロが実行されても困るので、アイディアを、いただけたらと存じます。

どうぞよろしくお願いします。

＜使用 Excel：Excel2007、使用 OS：Windows8 ＞

Application.InputBox メソッド(InputBox関数ではなく）のType:=8　を指定して、
ユーザーにセル範囲の指定を求めることができます。
これを利用してみてはどうですか？
# されたいことが十分理解できていませんが。
（γ） 2018/01/06(土) 07:43

＞予約、貸出はボタンから自動で名前が入るように作れたのですが、

それは、どのようなコードでしょうか。

＞取消ボタンを作りたくおもっています。
＞取消実行ボタンで、名前を消す作業をしたく思ってます。

名前を、空欄状態で、予約、貸出はボタンをクリックすると、
結果的に、名前は消えそうな気がしますが
違いますか。

（マナ） 2018/01/06(土) 08:21

マナさまありがとうございます。

作成したマクロです。

Private Sub CommandButton1_Click()

If ComboBox2 = "" Then

MsgBox "部署名と名前を入力してください"
Exit Sub

Else

End If
If ComboBox4 = "" Then

MsgBox "品物を選んでください"
Exit Sub

Else

End If

If TextBox3.Text = "" Then

MsgBox "行先を入力してください"

Exit Sub

Else

End If

    Dim shtmei As String

    shtmei = Me.ComboBox3.Value

    Sheets(shtmei).Activate

If TextBox1 = TextBox2 Then

 Rows("1:1").Select
    Selection.Find(What:=ComboBox4, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False).Select

    Dim n As Long

    n = Selection.Column

    Columns("A:A").Select
    Application.FindFormat.NumberFormat = "yyyy/mm/dd"
    Selection.Find(What:=TextBox1, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=True).Select

    Dim a As Long

    a = Selection.Row

    If Cells(a, n).Value = "" Then

    Cells(a, n).Value = "予約-" & ComboBox2

With Cells(a, n).Interior

        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13421823
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = -0.249977111117893

    Else: MsgBox "予約中または予約中です"

     Cells(1, 1).Select

      Exit Sub
    End If

Else:

        Rows("1:1").Select
    Selection.Find(What:=ComboBox4, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False).Select

    Dim p As Long

    p = Selection.Column

    Columns("A:A").Select
    Application.FindFormat.NumberFormat = "yyyy/mm/dd"
    Selection.Find(What:=TextBox1, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=True).Select

    Dim c As Long

    c = Selection.Row

        Rows("1:1").Select
         Selection.Find(What:=ComboBox4, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=False).Select

    Dim o As Long

    o = Selection.Column

    Columns("A:A").Select
    Application.FindFormat.NumberFormat = "yyyy/mm/dd"
    Selection.Find(What:=TextBox2, After:=ActiveCell, LookIn:=xlValues, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False, SearchFormat:=True).Select

    Dim b As Long

    b = Selection.Row

    If Range(Cells(c, p), Cells(b, o)).Value = "" Then

    Range(Cells(c, p), Cells(b, o)).Value = "予約-" & ComboBox2

With Range(Cells(c, p), Cells(b, o)).Interior

        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 13421823
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = -0.249977111117893

    End With

Else: MsgBox "予約中または予約中です"

    Cells(1, 1).Select

    Exit Sub

    End If

End If

With ThisWorkbook.Worksheets("全履歴").Select
Dim z As Long

z = Cells(Rows.Count, "A").End(xlUp).Row + 1

    Range("A" & z).Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("B" & z).Select
    ActiveCell.FormulaR1C1 = TextBox1.Text
   Range("C" & z).Select
    ActiveCell.FormulaR1C1 = TextBox2.Text
  Range("D" & z).Select
    ActiveCell.FormulaR1C1 = ComboBox4.Text
  Range("E" & z).Select
    ActiveCell.FormulaR1C1 = "予約"
  Range("F" & z).Select
    ActiveCell.FormulaR1C1 = ComboBox1.Text
  Range("G" & z).Select
    ActiveCell.FormulaR1C1 = ComboBox2.Text
  Range("H" & z).Select
    ActiveCell.FormulaR1C1 = TextBox3.Text

End With

    UserForm2.Hide

UserForm2.StartUpPosition = 0

 UserForm2.Top = Application.Top + 200
 UserForm2.Left = Application.Left + 300
 UserForm2.Show vbModeless

Sheets(shtmei).Activate

End Sub

作成しました。

γさまありがとうございます。
このようなメソッドはじめてしりました。
教えていただいたメソッドでできそうです。

複数あるシートも選択したいのですが不可能でしょうか？

後だしで申し訳ございません。よろしくお願いいたします。
（なか） 2018/01/06(土) 10:35

読みにくいので、最初のほうだけ書き直しました。

完成までに程遠いですが
わたしのコメントのイメージはこういうことです。

＞名前を、空欄状態で、予約、貸出はボタンをクリックすると、
＞結果的に、名前は消えそうな気がしますが

 Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim 品物列, 日付行
    Dim r As Range

    If ComboBox4.Text = "" Then
        MsgBox "品物を選んでください"
        Exit Sub
    End If

    If TextBox3.Text = "" Then
        MsgBox "行先を入力してください"
        Exit Sub
    End If

    Set ws = Sheets(ComboBox3.Text)

    If TextBox1.Text = TextBox2.Text Then

        品物列 = Application.Match(ComboBox4.Text, ws.Rows(1), 0)
        日付行 = Application.Match(CLng(CDate(TextBox1.Text)), ws.Columns(1), 0)

        Set r = ws.Cells(日付行, 品物列)

        If ComboBox2.Text <> "" Then
            If r.Value = "" Then
                r.Value = "予約-" & ComboBox2.Text
                r.Interior.Color = 13421823
                r.Font.ThemeColor = xlThemeColorAccent2
            Else
                MsgBox "予約中または予約中です"
                Application.Goto ws.Cells(1, 1)
                Exit Sub
            End If
        Else
            If r.Value <> "" Then
                If MsgBox("予約を取り消しますか？", vbYesNo) = vbYes Then
                    r.ClearContents
                End If
            End If
        End If

    Else

        '省略

    End If

 End Sub

（マナ） 2018/01/06(土) 13:14

2/3ほどまで、書換えました。
色つけるのは、条件付き書式でよいと勝手に判断しました。

 Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim 品物列, 日付行1, 日付行2
    Dim r As Range

    If ComboBox4.Text = "" Then
        MsgBox "品物を選んでください"
        Exit Sub
    End If

    If TextBox3.Text = "" Then
        MsgBox "行先を入力してください"
        Exit Sub
    End If

    Set ws = Sheets(ComboBox3.Text)

    品物列 = Application.Match(ComboBox4.Text, ws.Rows(1), 0)
    日付行1 = Application.Match(CLng(CDate(TextBox1.Text)), ws.Columns(1), 0)
    日付行2 = Application.Match(CLng(CDate(TextBox2.Text)), ws.Columns(1), 0)

    Set r = ws.Cells(日付行1, 品物列).Resize(日付行2 - 日付行1 + 1)

    If ComboBox2.Text <> "" Then
        If WorksheetFunction.CountA(r) = 0 Then
            r.Value = "予約-" & ComboBox2.Text
        Else
            MsgBox "予約中または予約中です"
            Application.Goto ws.Cells(1, 1)
            Exit Sub
        End If
    Else
        If WorksheetFunction.CountA(r) > 0 Then
            If MsgBox("予約を取り消しますか？", vbYesNo) = vbYes Then
                r.ClearContents
            End If
        End If
    End If

    '省略

 End Sub

（マナ） 2018/01/06(土) 14:09

最後の部分も書き直しました。
エラー対策は一切していませんが、
動作イメージの確認には支障ないと思います。
試してみて違うなと思えば無視してください。

 Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    Dim 品物列, 日付行1, 日付行2
    Dim r As Range
    Dim z As Long

    If ComboBox4.Text = "" Then
        MsgBox "品物を選んでください"
        Exit Sub
    End If

    If TextBox3.Text = "" Then
        MsgBox "行先を入力してください"
        Exit Sub
    End If

    Set ws = Worksheets(ComboBox3.Text)

    品物列 = Application.Match(ComboBox4.Text, ws.Rows(1), 0)
    日付行1 = Application.Match(CLng(CDate(TextBox1.Text)), ws.Columns(1), 0)
    日付行2 = Application.Match(CLng(CDate(TextBox2.Text)), ws.Columns(1), 0)

    Set r = ws.Cells(日付行1, 品物列).Resize(日付行2 - 日付行1 + 1)

    If ComboBox2.Text <> "" Then
        If WorksheetFunction.CountA(r) = 0 Then
            r.Value = "予約-" & ComboBox2.Text
        Else
            MsgBox "予約中または予約中です"
            Application.Goto ws.Cells(1, 1)
            Exit Sub
        End If
    Else
        If WorksheetFunction.CountA(r) > 0 Then
            If MsgBox("予約を取り消しますか？", vbYesNo) = vbYes Then
                r.ClearContents
            Else
                Exit Sub
            End If
        End If
    End If

    With ThisWorkbook.Worksheets("全履歴")
        z = .Cells(Rows.Count, "A").End(xlUp).Row + 1
        .Cells(z, "A").Value = Now
        .Cells(z, "B").Value = TextBox1.Text
        .Cells(z, "C").Value = TextBox2.Text
        .Cells(z, "D").Value = ComboBox4.Text
        .Cells(z, "E").Value = IIf(ComboBox2.Text <> "", "予約", "解約")
        .Cells(z, "F").Value = ComboBox1.Text
        .Cells(z, "G").Value = ComboBox2.Text
        .Cells(z, "H").Value = TextBox3.Text
    End With

 End Sub

（マナ） 2018/01/06(土) 15:25

マナさまありがとうございます。

お恥ずかしい話変数日本語が使えるとも知りませんでした。

何度も申し訳ございません。

予約と取り消しを別のボタンで行いたいと思っております。

この場合解約はどのような方法になるのでしょうか？

WorksheetFunction.CountA(r) > 0 Thenの意味が分からずもうしわけございません。
（なか） 2018/01/06(土) 17:42

申し訳ありません。
実は、なぜそんなまわりくどいことするのか、よくわかっていません。

 ＞イメージとしては、ユーザーフォームにて取消ボタンをクリックすると、…

マクロ使わずに、セルを選択してDeleteキーを押すだけでは？

（マナ） 2018/01/06(土) 18:27

マナさま

マナさまのマクロだと全履歴に人が残らないのです。

全履歴を確認知ればわかるのですが、できるだけ誰がどの作業をしたか履歴を残したく考えています。

予約した数日後に解約する場合。

わざわざ前回予約した日付を入力するのが手間なので、取り消したいセルをユーザにクリックしてもらおうとと考えていました。

しかしとてもシンプルなマクロになってまだまだ自分の未熟さを知りました。ありがとうございます。
（なか） 2018/01/06(土) 19:02

＞わざわざ前回予約した日付を入力するのが手間なので

それならば、予約のときもセル選択方式がよいのでは？

（マナ） 2018/01/06(土) 19:50

例えば、こんな感じで情報を取得します

 Sub test()
    Dim r As Range
    Dim 品物 As String
    Dim 日付1 As String
    Dim 日付2 As String
    Dim 行先 As String

    On Error Resume Next
    Set r = Application.InputBox("セル選択", Type:=8)
    On Error GoTo 0
    If r Is Nothing Then Exit Sub

    品物 = r.EntireColumn.Cells(1).Value
    日付1 = r(1).EntireRow.Cells(1).Value
    日付2 = r(r.Count).EntireRow.Cells(1).Value
    行先 = r.Parent.Name

    MsgBox 品物 & vbLf & 日付1 & vbLf & 日付2 & vbLf & 行先

 End Sub

（マナ） 2018/01/06(土) 20:12

マナさま

ありがとうございます。
そうですね。逆に予約も日付で選べばいいですね。

いただいたマクロもテストしておこなってみます。

ありがとうございます。
（なか） 2018/01/07(日) 13:45

コメント返信：

[ 一覧(最新更新順) ]

[[20180105233753]] 『ユーザーフォーム ボタンクリック後、人によるセメx（なか） ページの最後に飛ぶ

[[20180105233753]]　『ユーザーフォームボタンクリック後、人によるセメx（なか）　ページの最後に飛ぶ