教えて! goo のコンテンツに対する取り組みについて

VBE初心者ですみません。
VBEコーディングしていたのですが、VBE起動はするのですが永遠に終わらずにフリーズしてしまします。
助けていただけると幸いです。
内容は下記になります。

(”TBL_2021年度”)のシート上にあるユーザーフォームを使い(”TBL_2021年度”)のシートの最下行にデータ登録を行いたい。
■詳細
登録内容は下記(ユーザーフォーム)
・氏名(空白・重複チェック)
・部署(空白チェック)
・利用開始日(空白チェック)
・PC分類(空白チェック)
・引当PC(空白チェック)
・備考

上記内容で登録するのですが、まずユーザーフォーム登録時に下記TextBoxが空白かチェックする機能をつけています。
・氏名(空白・重複チェック)
・部署(空白チェック)
・利用開始日(空白チェック)
・PC分類(空白チェック)
・引当PC(空白チェック)
上記内容に空白がなかった場合、(”TBL_2021年度”)のシートのB列の氏名に今回追加する氏名が重複していないかチェックします。

チェックした結果重複していなければ、(”TBL_2021年度”)のシートの最下行にデータ追加及び、メール(ベッキー)にて内容送信するようにしたいのですが可能でしょうか?

私、初心者なので、具体的なコード例があると幸いです。

下記、作成したコード内容です。

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー

Sub フォーム起動_Click()

登録foam.Show

End Sub

'ユーザーフォーム登録をクリック
Private Sub page1登録_Click()

'更新画面の停止
Application.ScreenUpdating = False

If TextBox氏名 = "" Or ComboBox使用分類 = "" Or ComboBox部署 = "" Or TextBox利用開始日 = "" Or TextBoxPC分類 = "" Or TextBo引当PC = "" Then
MsgBox "未入力箇所があります"
Else

If Range("B:B").Value = TextBox氏名 Then
MsgBox ("対象者が重複しています")
Else

If Range("BC6").Offset(1) = "" Then
Range("BC6").Offset(1).Value = TextBox氏名.Value
Range("BC6").Offset(1, 1).Value = ComboBox部署.Value
Range("BC6").Offset(1, 2).Value = TextBox利用開始日.Value
Range("BC6").Offset(1, 3).Value = TextBoxPC分類.Value
Range("BC6").Offset(1, 4).Value = TextBox引当PC.Value
Range("BC6").Offset(1, 4).Value = TextBox使用分類.Value
Range("BC6").Offset(1, 5).Value = TextBoxpage1備考.Value
End If

Range("B6").End(xlDown).Offset(1).Value = TextBox氏名.Value
Range("BC6").End(xlDown).Offset(1).Value = ComboBox部署.Value
Range("BD6").End(xlDown).Offset(1).Value = TextBox利用開始日.Value
Range("BE6").End(xlDown).Offset(1).Value = TextBoxPC分類.Value
Range("BF6").End(xlDown).Offset(1).Value = TextBox引当PC.Value
Range("BF6").End(xlDown).Offset(1).Value = TextBox使用分類.Value
Range("BG6").End(xlDown).Offset(1).Value = TextBoxpage1備考.Value

End If
End If

Sheets("TBL_2021年度").Select
strTO = Range("D3") '宛先アドレス
strCC = Range("E3") ' CCアドレス
strBCC = Range("F3") 'BCCアドレス
strSubject = Range("G3") 'タイトル文
strBody = Range("H3:M3") '本文
Shell "C:Program Files (x86)RimArtsB2B2.exe mailto:" & strTO & "?cc=" & strCC & "?bcc=" & strBCC & " ?&subject=" & strSubject & "&body=" & strBody, vbNormalFocusocus

Unload 登録foam
Application.ScreenUpdating = Ture
End Sub

質問者からの補足コメント

  • 回答ありがとうございます。
    もし、B列にTextBox氏名に書いてある内容があれば(重複しています)メッセージを出すようにするように、書いたつもりでした。
    具体的にどのように修正すれば改善できるでしょうか?

    No.2の回答に寄せられた補足コメントです。 補足日時:2021/08/22 17:25
gooドクター

A 回答 (6件)

解決出来たかな?


>(”TBL_2021年度”)のシート上にあるユーザーフォームを使い(”TBL_2021年度”)のシートの最下行にデータ登録を行いたい。
>チェックした結果重複していなければ、(”TBL_2021年度”)のシートの最下行にデータ追加及び、メール(ベッキー)にて内容送信する

すべてのコントロールが設置されたフォームモジュールに
下記、Private Sub page1登録_Click()~End Functionまで
すべてをコピペ

'ユーザーフォーム登録をクリック
Private Sub page1登録_Click()
Dim strMsg As String, strTO As String, strCC As String
Dim strBCC As String, strSubject As String, strBody As String
Dim dataAry(5)
If CHK_Val(strMsg) <> "" Then
MsgBox "未入力箇所" & vbCrLf & vbCrLf & _
strMsg & vbCrLf & "上記項目を入力してください"
Exit Sub
End If
'データを変数に代入
dataAry(0) = ComboBox部署.Value
dataAry(1) = TextBox利用開始日.Value
dataAry(2) = TextBoxPC分類.Value
dataAry(3) = TextBox引当PC.Value
dataAry(4) = ComboBox使用分類.Value
dataAry(5) = TextBoxpage1備考.Value

strTO = Range("D3").Value '宛先アドレス
strCC = Range("E3").Value ' CCアドレス
strBCC = Range("F3").Value 'BCCアドレス
strSubject = Range("G3").Value 'タイトル文
strBody = Range("H3") '本文
'main
Application.ScreenUpdating = False
With Cells(Rows.Count, "BC").End(xlUp)
If Range("BC7").Value = "" Then
Range("B7").Value = TextBox氏名.Value
Range("BC7").Resize(, 6).Value = dataAry
Else
.Offset(1, -53).Value = TextBox氏名.Value 'BC -53 B列
.Offset(1).Resize(, 6).Value = dataAry
End If
End With
'Becky! 2は無いので未検証
Shell "C:\Program Files (x86)\RimArts\B2\B2.exe mailto:" _
& strTO & "?cc=" & strCC & "?bcc=" & strBCC & "?subject=" & strSubject & "?body=" & strBody, vbNormalFocus

Application.ScreenUpdating = True
Unload 登録foam

End Sub

Private Sub TextBox氏名_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If TextBox氏名.Value <> "" Then
If Application.CountIf(Range("B:B"), TextBox氏名.Value) > 0 Then
MsgBox ("対象者が重複しています")
Cancel = True
Exit Sub
End If
End If
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If TextBox氏名.Value <> "" Then TextBox氏名.Value = ""
End Sub

Public Function CHK_Val(strMsg As String)
If TextBox氏名.Value = "" Then strMsg = "氏名" & vbCrLf
If ComboBox使用分類.Value = "" Then strMsg = strMsg & "使用分類" & vbCrLf
If ComboBox部署.Value = "" Then strMsg = strMsg & "部署" & vbCrLf
If TextBox利用開始日.Value = "" Then strMsg = strMsg & "利用開始日" & vbCrLf
If TextBoxPC分類.Value = "" Then strMsg = strMsg & "分類" & vbCrLf
If TextBo引当PC.Value = "" Then strMsg = strMsg & "引当PC" & vbCrLf
CHK_Val = strMsg
End Function
    • good
    • 0

#4です


vbNormalFocusocus が気になったので 
Shell コードを確認すると・・・
RimArtsB2B2 なのかな? \RimArts\B2\B2 では、、、
実際のB2.exe のアドレスは分かりませんが、、実際のものに。
少なくともFiles (x86)RimArtsは無いのではと、、、

vbNormalFocusocus、、これはvb なのでvbNormalFocus かと
(ベッキー)自体知らないので、、あとは分かりませんが追記します。
    • good
    • 0

こんばんは


直接の回答にならないと存じますが、
タイプミスもあるようなので、現段階で修正した方が良いと思う点と確認を

先ず、
>シート上にあるユーザーフォームを使い
①これは、シート上のボタンからユーザーフォームを呼び、、と言う意味で良いでしょうか?

②各テキストボックスなどはユーザーフォーム上に作られているもので良いですか。

Sub フォーム起動_Click()
登録foam.Show
End Sub

③これは、シートモジュールに記載しているで良いでしょうか?

Private Sub page1登録_Click()
④これは、フォームモジュール(登録foam)に記載しているで良いでしょうか?

コードについて、

空白チェック、重複チェックは、合った場合、実行しないのですから
IFは閉じた方がわかり易いと思います。(メイン処理に移行させない)

下記サンプル
Private Sub page1登録_Click()
If TextBox氏名.Value = "" _
Or ComboBox使用分類.Value = "" _
Or ComboBox部署.Value = "" _
Or TextBox利用開始日.Value = "" _
Or TextBoxPC分類.Value = "" _
Or TextBo引当PC.Value = "" Then
MsgBox "未入力箇所があります"
Exit Sub 'page1登録_Clickをここで実行終了
End If

If WorksheetFunction.CountIf(Range("B:B"), TextBox氏名.Value) > 0 Then
MsgBox ("対象者が重複しています")
Exit Sub
End If

'更新画面の停止
Application.ScreenUpdating = False


Exit Sub としてもユーザーフォームは閉じられません。

空白チェックは、どこが未入力か分からいとせっかくのUIがもったいないので、こんな書き方もあります

If TextBox氏名.Value = "" Then strMsg = "氏名" & vbCrLf
If ComboBox使用分類.Value = "" Then strMsg = strMsg & "使用分類" & vbCrLf
If ComboBox部署.Value = "" Then strMsg = strMsg & "部署" & vbCrLf
If TextBox利用開始日.Value = "" Then strMsg = strMsg & "利用開始日" & vbCrLf
If TextBoxPC分類.Value = "" Then strMsg = strMsg & "分類" & vbCrLf
If TextBo引当PC.Value = "" Then strMsg = strMsg & "引当PC" & vbCrLf
If strMsg <> "" Then
MsgBox "未入力箇所" & vbCrLf & strMsg & "を入力してください"
Exit Sub
End If

ここまでは、書き方の問題なのでスタックの原因であるかは分かりません。

あと、メール(ベッキー)は分かりませんが

strBody = Range("H3:M3") '本文
このセルは結合されているのでしょうか、、.Valueが取得できないような気がします。

Shell が問題があるのなら、メール(ベッキー)の使用を確認する必要があると思いますね。

①②③④の一部は、すでにご質問文にありますが、念のため。
    • good
    • 0

If WorksheetFunction.CountIf(range("B:B"),TextBox氏名) > 0 Then



かな?

でもフリーズするのはここが原因とは思えないです。

End If

Stop '追加してみて前半でフリーズするのかを調べてみる。
'問題なければ中断から進めて後半でフリーズするのか否か???

Sheets("TBL_2021年度").Select
    • good
    • 0

少なくとも未入力箇所がなければ、



>If Range("B:B").Value = TextBox氏名 Then

ここでエラーになって止まると思いますけど?
この回答への補足あり
    • good
    • 0

ステップ実行してみてください。

    • good
    • 0

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

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

gooドクター

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング