アプリ版:「スタンプのみでお礼する」機能のリリースについて

エクセルでデータベースを作り、ユーザーフォームにて
入力作業を行っています。
フォーム上にテキストボックスが2つ有り、
一つは日付、もう一つは名称を入力する仕様と
なっています。
またシートへの書き込みはコマンドボタンで
処理を行うようにしています。

このフォームで日付と名称を入力したときに、
そのデータをシートに書き込む前に
同じデータがすでにデータベースの中にある場合に
重複がある旨のメッセージダイアログを表示させたいと
思います。

処理条件としては、
1.日付、名称それぞれのテキストボックスを
抜けたとき(Private Sub TextBox1_Exit())に
処理させること
2.入力した日付と同じ日付のデータベースにおいて
名称が同じかどうかで判断すること
3.重複があればダイアログ表示、なければ何もなし

ちなみにデータベースはA列に日付、B列に名称が
入っているものとします。
また上に処理条件を記しましたが、もっと良い方法が
あれば加えてアドバイス願います。

VBA初心者ですので解説付きコードで教えてください。
(非常にあつかましいのですが、余り時間がないため、
明日の朝9時までにご回答頂けると非常に助かります。
その際、もっとも的確で早い回答をくださった方に
20ポイントつけさせて頂きます。)

どうぞ宜しくお願いします。

A 回答 (2件)

スルーしようかとも思いましたが、希望納期も過ぎましたし、そろそろいいでしょうかw



まずは苦言から。「20ポイント」も愉快ではありませんが、「VBA初心者」を自称しておきながら不完全な「処理条件」を堂々と突きつける辺りにあきれて補足要求する気にすらなれませんでした。「これがやりたい」とだけ書いていただく方が、余程気持ちよく回答できます。
aoincさんがお金を出して下請けに作らせるのなら、このような方法でも良いのでしょうが、なにせここは「自発的な」回答者ばかりですので…w

最初に前提を書きます。
入力したデータを書き込むシートは仮に「Sheet1」とします。その他に作業用シートとして「Sheet2」があるものとします。
データ件数も分からないのでシート関数を併用する方法を採りました。その方がFor~Next文を使うより高速と思ったからです。

UserForm1には
 TextBox1 (日付入力用)
 TextBox2 (名前入力用)
 CommandButton1 (登録用)
 Label1 (警告メッセージ用)
が配置されているものとします。その上でUserForm1のコードシートに以下を貼り付けてイミディエイトペインから
 UserForm1.Show
で動かしてみてください。

フォーカスのコントロールは私の思いこみで書いています。データエラーチェックはしていませんので必要に応じて追加してください。またその他のコントロールについてはご自由になさってください。(そこまでは「処理条件」に書かれていませんでしたので…)

Option Explicit
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
 Label1.Caption = ""
 CommandButton1.Enabled = True
 Sheets("Sheet2").Range("A1") = TextBox1.Text
 If Sheets("Sheet2").Range("A3") > 0 Then
  Label1.Caption = "重複あり"
  CommandButton1.Enabled = False
 End If
End Sub

Private Sub TextBox2_change()
 Label1.Caption = ""
 Sheets("Sheet2").Range("A2") = TextBox2.Text
 If Sheets("Sheet2").Range("A3") > 0 Then
  Label1.Caption = "重複あり"
  CommandButton1.Enabled = False
 Else
  CommandButton1.Enabled = True
 End If
End Sub

Private Sub CommandButton1_Click()
Dim LastR As Long
 LastR = Sheets("Sheet1").Range("A65536").End(xlUp).Row
 Sheets("Sheet1").Cells(LastR + 1, 1) = TextBox1.Text
 Sheets("Sheet1").Cells(LastR + 1, 2) = TextBox2.Text
 Sheets("Sheet2").Range("A3").Formula = "=SUMPRODUCT((Sheet1!A2:A" & _
  LastR + 1 & "=A1)*(Sheet1!$B$2:$B$" & LastR + 1 & "=A2)*1)"
 TextBox2.Text = ""
 Sheets("Sheet2").Range("A2") = TextBox2.Text
 TextBox2.SetFocus
End Sub

Private Sub UserForm_Activate()
Dim LastR As Long
 LastR = Sheets("Sheet1").Range("A65536").End(xlUp).Row
 Sheets("Sheet2").Range("A3").Formula = "=SUMPRODUCT((Sheet1!A2:A" & _
  LastR + 1 & "=A1)*(Sheet1!$B$2:$B$" & LastR + 1 & "=A2)*1)"
End Sub

動作は確認してありますが、解説は遠慮しておきます。ポイントも勿論いりません。
    • good
    • 2

こんばんは。



10行もあればすむコードに何故回答がつかないのか、
それはたぶん最後の
>もっとも的確で早い回答をくださった方に20ポイントつけさせて頂きます
この余計なコメントのせいだろうと推測。

何にもならないポイント欲しさに回答する人、いないと思ふ。(^^;;;
何れにしろ人にものを教えてもらう態度ではない。
以上。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています