[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAの機能追加について』（「ニックネームをお忘れなく」と表示されてもつける気のない人）
こんにちは、いつもみなさんのｱﾄﾞﾊﾞｲｽとても助かっています。 今回は下記のＶＢＡに次の機能を追加したいのですが、数式がわかりません。
Private Sub CommandButton2_Click() '削除
Dim 選択行 As Integer
Dim 参照範囲行 As Integer
Dim 参照番号 As Variant
Dim 参照元 As Variant
Dim 応答 As Variant
If TextBox17 = "" Then
Label16.Caption = "削除する行番号を入力してください｡ "
TextBox17.SetFocus
Else
応答 = MsgBox("データを削除します。よろしいですか？", _
vbOKCancel, "データの削除")
If 応答 = vbOK Then
Range("A1").Activate
ActiveSheet.Unprotect
Label17.Caption = "削除中です。"
DoEvents
Label16.Caption = ""
参照番号 = TextBox17.Value
For 参照範囲行 = 3 To 1000
参照元 = Cells(参照範囲行, 1).Text
If 参照元 = 参照番号 Then
選択行 = 参照範囲行
End If
Next 参照範囲行
If 選択行 <> 0 Then
Cells(選択行, 2).Value = "" '氏名
Cells(選択行, 3).Value = "" 'フリガナ
Cells(選択行, 4).Value = "" '敬称
Cells(選択行, 5).Value = "" '分類１
Cells(選択行, 6).Value = "" '分類２
Cells(選択行, 7).Value = "" '会社名
Cells(選択行, 8).Value = "" '部署名１
Cells(選択行, 9).Value = "" '部署名２
Cells(選択行, 10).Value = "" '役職名
Cells(選択行, 11).Value = "" '郵便番号１
Cells(選択行, 12).Value = "" 'Ｅメール
Cells(選択行, 13).Value = "" '住所１
Cells(選択行, 14).Value = "" '住所２
Cells(選択行, 15).Value = "" '電話番号
Cells(選択行, 16).Value = "" 'ファックス
Cells(選択行, 17).Value = "" '携帯電話
Cells(選択行, 20).Value = "" '住所１'
Cells(選択行, 21).Value = "" '住所２'
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios _
:=True
Label17.Caption = "削除完了です。"
TextBox1.Text = "" '氏名
TextBox4.Text = "" 'フリガナ
ComboBox1.Text = "" '敬称
ComboBox2.Text = "" '分類１
ComboBox3.Text = "" '分類２
TextBox6.Text = "" '会社名
TextBox7.Text = "" '部署名１
TextBox8.Text = "" '部署名２
TextBox9.Text = "" '役職名
TextBox10.Text = "" '郵便番号
TextBox18.Text = "" 'Ｅメール
TextBox12.Text = "" '住所１
TextBox13.Text = "" '住所２
TextBox14.Text = "" '電話番号
TextBox15.Text = "" 'ファックス
TextBox16.Text = "" '携帯電話
Label16.Caption = "[次へ]ボタンで次の行へ移ります。"
End If
If 応答 = vbCancel Then
Exit Sub
End If
End If
End If
End Sub
Private Sub CommandButton3_Click() '更新
Dim 選択行 As Integer
Dim 参照範囲行 As Integer
Dim 参照番号 As Variant
Dim 参照元 As Variant
Dim 応答 As Variant
Dim 行 As Variant
If TextBox17 = "" Then
Label16.Caption = "更新する行番号を検索してください。"
TextBox4.SetFocus
Else
応答 = MsgBox("データを更新します。よろしいですか？", _
vbOKCancel, "データの更新")
If 応答 = vbOK Then
Range("A1").Select
ActiveSheet.Unprotect
Label17.Caption = "更新中です。"
DoEvents
Label16.Caption = ""
参照番号 = TextBox17.Value
For 参照範囲行 = 3 To 1000
参照元 = Cells(参照範囲行, 1).Text
If 参照元 = 参照番号 Then
選択行 = 参照範囲行
End If
Next 参照範囲行
If 選択行 <> 0 Then
Cells(選択行, 2).Value = TextBox1.Text '氏名
Cells(選択行, 3).Value = TextBox4.Text 'フリガナ
Cells(選択行, 4).Value = ComboBox1.Text '敬称
Cells(選択行, 5).Value = ComboBox2.Text '分類１
Cells(選択行, 6).Value = ComboBox3.Text '分類２
Cells(選択行, 7).Value = TextBox6.Text '会社名
Cells(選択行, 8).Value = TextBox7.Text '部署名１
Cells(選択行, 9).Value = TextBox8.Text '部署名２
Cells(選択行, 10).Value = TextBox9.Text '役職名
Cells(選択行, 11).Value = TextBox10.Text '郵便番号
Cells(選択行, 12).Value = TextBox18.Text 'Eメール
Cells(選択行, 13).Value = TextBox12.Text '住所１
Cells(選択行, 14).Value = TextBox13.Text '住所２
Cells(選択行, 15).Value = TextBox14.Text '電話番号
Cells(選択行, 16).Value = TextBox15.Text 'ファックス
Cells(選択行, 17).Value = TextBox16.Text '携帯電話
For Each 行 In Range("L3:L1000")
If 行.Value <> "" Then
ActiveSheet.Hyperlinks.Add 行, "mailto:" & 行.Value
End If
Next 行
Range("L3:L1000").Select
With Selection.Font
.Name = "ＭＳ Ｐゴシック"
.Size = 11
End With
'関数の再書き込み
Range("T3").Select
ActiveCell.FormulaR1C1 = "=RC[-7]"
Range("U3").Select
ActiveCell.FormulaR1C1 = "=RC[-7]"
Range("T3:U3").Select
Selection.Copy
Range("T4:T1000").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("T4:U1000").Select
Range("T28").Activate
'住所を漢数字に変換
Range("T3:U1000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Range("T3:U1000")
.Replace What:="１", Replacement:="一"
.Replace What:="２", Replacement:="二"
.Replace What:="３", Replacement:="三"
.Replace What:="４", Replacement:="四"
.Replace What:="５", Replacement:="五"
.Replace What:="６", Replacement:="六"
.Replace What:="７", Replacement:="七"
.Replace What:="８", Replacement:="八"
.Replace What:="９", Replacement:="九"
.Replace What:="０", Replacement:="〇"
.Replace What:="－", Replacement:="の"
End With
ActiveSheet.Protect
Range("A1").Select
Label17.Caption = "更新完了です。"
Label16.Caption = "[次へ]ボタンで次の行へ移ります。"
End If
If 応答 = vbCancel Then
Exit Sub
End If
End If
End If
End Sub
Private Sub CommandButton4_Click()
TextBox1.Text = "" '氏名
TextBox4.Text = "" 'フリガナ
ComboBox1.Text = "" '敬称
ComboBox2.Text = "" '分類１
ComboBox3.Text = "" '分類２
TextBox6.Text = "" '会社名
TextBox7.Text = "" '部署名１
TextBox8.Text = "" '部署名２
TextBox9.Text = "" '役職名
TextBox10.Text = "" '郵便番号
TextBox18.Text = "" 'Eメール
TextBox12.Text = "" '住所１
TextBox13.Text = "" '住所２
TextBox14.Text = "" '電話番号
TextBox15.Text = "" 'ファックス
TextBox16.Text = "" '携帯電話
TextBox17.Text = "" 'No.
UserForm2.Hide
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 3
End Sub
名簿マスターをいうシートに顧客先の住所録が２００件程あります。 セルＢに氏名が入力されていて、そこにセルをあわせてマクロボタンを押すと、その氏名の方の詳細が表示されます。 そこに削除という項目もあり、それを押すとそのデータが消えます。
今現在ではそのまま消去されてしまうのですが、別シートに削除シートを作成し、そちらに移行する事は可能でしょうか？
つまり、
今→削除されたらデータから完全に消去される。希望→削除された事がわかる様に別シートに移行し保管。 又は、削除されず色のみ変わるというものにしたいです。
＞削除されず色のみ変わる でしたら、 If 選択行 <> 0 Then の後で、セル内のデータを消していますが 代わりにセルの色を変更する事にすれば良さそうです。
＞別シートに移行し保管。 の場合は If 選択行 <> 0 Then の後で、セル内のデータを消していますが その前に、転記しておけば良さそうです。
現在のコードを踏襲するなら
削除シートの書き込む行を取得して。。。
書込行 = Sheets("削除シート").Cells("B" & Rows.Count).End(xlUp).Row + 1
Sheets("削除シート").Cells(書込行, 2).Value = Cells(選択行, 2).Value
：
：
等と言った感じで。
(HANA)
ＨＡＮＡさんの言う通りなのですが、
セルの色を変更する式がわかりません。
具体的に見本的な式を教えていただけませんか？
確認なんですが、 ニックネームを変更されたのはスレ主さんですか？ (mitsu)
スレ主さんは、こちらの方だと思います。 ↓ [[20091111154351]]『文字を表示させない方法』（みかん）
セルの色を変更するコードは マクロの記録で取得して下さい。
載せて居られるコードは、ご自身で作成したものではないのですか？
(HANA)
ＨＡＮＡさんコメントありがとうございます。 初心者で申し訳ありません。
＞別シートに移行し保管。 ＞の場合は ＞If 選択行 <> 0 Then ＞の後で、セル内のデータを消していますが ＞その前に、転記しておけば良さそうです。 これなのですが、どの部分の前に何を転記すればよいのでしょうか？
また、
書込行 = Sheets("削除シート").Cells("B" & Rows.Count).End(xlUp).Row + 1
Sheets("削除シート").Cells(書込行, 2).Value = Cells(選択行, 2).Value
これはどこに入力すればよいのでしょうか？
で、だから↑誰なんでしょー？
コメント返信するときに 青文字で「ニックネームをお忘れなく」と 表示されてるのが気づきませんか？ （とおりすがり）
まず、この掲示板の使い方ですが
１．署名は自動では入りません。 コメント記入の際は、その都度ご署名をお願いします。
２．文頭に半角スペースを入れると、改行がそのまま表示されます。 _←ここに半角スペースです。 投稿前に プレビュー画面で確認して下さい。
それから、ゆっくりで良いので 書いてあることを良く読み 方針を定めて、応答して下さるようお願いします。
ご要望として 『１』別シートに移行し保管。 『２』削除されず色のみ変わるでも良い。 と二つありました。
＞セルの色を変更する式がわかりません。 ＞具体的に見本的な式を教えていただけませんか？ このご質問は 『２』に関する物であり
＞これはどこに入力すればよいのでしょうか？ のご質問は『１』に関する物です。
まずは方針を決めて頂くのが良いのではないかと思いますが。
それから ＞＞スレ主さんは、こちらの方だと思います。 これは、合っているのですか？違っているのですか？
＞＞載せて居られるコードは、ご自身で作成したものではないのですか？ これに関するご返答はどうでしょう？
(HANA)
マルチポストでしたか (mitsu) http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=63502;id=excel
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.