ここから本文です

EXCELで顧客管理名簿を作成しています。 VBAで新規・修正登録のボタンを作りたい...

アバター

ID非公開さん

2015/6/600:40:21

EXCELで顧客管理名簿を作成しています。
VBAで新規・修正登録のボタンを作りたいのですが、
上手くできません。

顧客名簿にないIDの場合は新規で登録し、すでに名簿に登録されている
IDの場合は上書き修正できればと思っています。

sheet1(新規登録・修正したい顧客情報)
ㅤㅤㅤㅤCㅤㅤㅤㅤㅤㅤㅤ DㅤㅤㅤㅤㅤㅤE
6ㅤ顧客ID(文字列)ㅤ 顧客名(英字)ㅤ 顧客名(漢字)


sheet2(顧客名簿)
ㅤㅤㅤㅤAㅤㅤㅤㅤㅤㅤㅤ BㅤㅤㅤㅤㅤㅤC
2 ㅤ顧客ID(文字列) ㅤ顧客名(英字)ㅤ顧客名(漢字)
3 ㅤㅤㅤ〃
4 ㅤㅤㅤ〃



どなたかVBAに詳しい方、ご教示ください。

閲覧数:
1,615
回答数:
3
お礼:
500枚

違反報告

ベストアンサーに選ばれた回答

hotosysさん

2015/6/605:42:12

Sheet1にActiveXコントロールのボタンを作ってください。
登録/修正用のボタンになります。
プログラム中ではCommandButton1です。

まず、最初に一度だけ
Sub setting()
Sheets("Sheet1").ScrollArea = "C6:E6"
Sheets("Sheet1").Range("C6:E6").NumberFormat = "@"
Sheets("Sheet2").Range("A:C").NumberFormat = "@"
End Sub
を実行してください。
Sheet1のカーソルの移動範囲を"C6:E6"に限定します。
また、データ範囲の書式を文字列にします。
("001"が"1"になったりするのを防止します)


シートのChangeイベントを使っているので、以下をSheet1のVBA部に入れてください。

Private Sub Worksheet_Change(ByVal Target As Range)
'チェック
Set Target = Intersect(Target, Range("C6")) '複数ペーストに備えてC6(顧客ID)だけを取得
If Target Is Nothing Then Exit Sub 'C6でなかったら中止
'顧客IDによる処理
If Target.Value = "" Then '顧客IDが空白なら
'クリア
Range("B6,D6,E6").ClearContents '作業名,顧客名(英字),顧客名(漢字)クリア
Else
'データ読み込み
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("Sheet2") 'データシート
Set rng = ws.Range("A:A").Find(Range("C6").Value, LookAt:=xlWhole) 'データシートのA列で顧客IDを検索
If rng Is Nothing Then '無かったら
Range("B6").Value = "新規"
Range("D6,E6").ClearContents '顧客名(英字),顧客名(漢字)クリア
Else 'あったら(rngが見つけたセル)
Range("B6").Value = "修正"
Range("D6").Value = ws.Range("B" & rng.Row).Value '顧客名(英字)読み込み
Range("E6").Value = ws.Range("C" & rng.Row).Value '顧客名(漢字)読み込み
End If
End If
End Sub

'登録ボタン
Private Sub CommandButton1_Click()
'チェック
If Range("C6").Value = "" Then '顧客IDが空白なら
Range("C6").Select '顧客ID選択
Exit Sub '中止
End If
'
Dim ws As Worksheet
Dim rng As Range
Set ws = Sheets("Sheet2") 'データシート
Set rng = ws.Range("A:A").Find(Range("C6").Value, LookAt:=xlWhole) 'データシートのA列で顧客IDを検索
If rng Is Nothing Then Set rng = ws.Range("A" & Rows.Count).End(xlUp).Offset(1) '無かったら新規の位置(A列最終行の1行下)が見つかった事にする
ws.Range("A" & rng.Row).Value = Range("C6").Value '顧客ID
ws.Range("B" & rng.Row).Value = Range("D6").Value '顧客名(英字)
ws.Range("C" & rng.Row).Value = Range("E6").Value '顧客名(漢字)
Range("C6").ClearContents '顧客IDクリア(Worksheet_Change)が発生して、他のデータもクリアされる
Range("C6").Select
End Sub

Sheet1にActiveXコントロールのボタンを作ってください。
登録/修正用のボタンになります。...

アバター

質問した人からのコメント

2015/6/6 19:08:08

皆様ののお陰で何とか完成することができました。
大変、感謝しております。

ベストアンサーは、最初に回答を頂きましたhotosysさんに
したいと思います。

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

kajackastroさん

2015/6/614:55:37

似たような動きをする機能を作ったことがありますが、私の場合ユーザーフォームで入力し、データをシートに保存する仕組みで作りました。
ユーザーフォームには適宜制御を入れてテキストボックス、ボタン、ラベル等を作成します。
コードは控えますが、登録ボタンをクリックした際に、findメソッド等を使い現在の登録状況を確認しメッセージボックス等でinsertかupdateの確認をさせます。メッセージボックスにはvbOkCancelを施しておきvbOkの場合データの書き換えとブックの保存を行います。vbCancelではキャンセルさせます。
このマクロを作る際に考慮しておくべきことは登録件数が実際にどれくらいになるかというところでしょう。65536件に到達することがないのであればブックの拡張子はxlsで耐えれますが、超える可能性があればxlsmにします。シートの最大行数が違うため。

helpnanodaさん

2015/6/608:17:51

一例です。
Sheet2にボタンを作成して、そのボタンに下のコードを登録してください。
コードの記述は標準モジュールです。

Sub Test()
Dim sh1 As Worksheet, sh2 As Worksheet, EndRow As Long
Dim Hani As Range, FC As Range, ID As String
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
EndRow = sh2.Range("A" & Rows.Count).End(xlUp).Row
With sh2
Set Hani = .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row)
ID = sh1.Range("C6").Value
Set FC = Hani.Find(What:=ID, LookAt:=xlWhole)
If Not FC Is Nothing Then
sh1.Range("C6").Resize(1, 3).Copy FC.Cells
Else
sh1.Range("C6").Resize(1, 3).Copy .Range("A" & EndRow + 1)
End If
End With
sh1.Range("C6").Select
End Sub

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

5文字以上入力してください

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。