第11回.顧客登録より顧客一覧へ更新
エクセルで顧客管理を作ります、
プログラム完成へ向けて一気に突き進みましょう、
今回は、「顧客登録」で入力した内容を、「顧客一覧」へ更新します。
「顧客番号」が存在しない場合は、最終行の次へ、
存在する場合は、その行へ更新します。
その前に、まずSubモジュール「顧客一覧より取得」を少し修正します。
1つは、バグがありましたので、修正します。
もう1点は、存在しない番号を入力した場合のメッセージを少し変更します。
Sub 顧客一覧より取得()
Dim r0 As Long '行番号ワーク
Dim r1
As Long, c1 As Long '顧客一覧の見出しの行,列位置
Dim r2 As Long, c2 As Long
'顧客登録の行,列位置
Dim rngFind As Range 'Findの結果保存
Call マクロ開始処理
r1 = 開始セル取得("顧客一覧").Row '顧客一覧の開始行位置を取得
c1 =
開始セル取得("顧客一覧").Column '顧客一覧の開始列位置を取得
r2 =
開始セル取得("顧客登録").Row '顧客登録の開始行位置を取得
c2 = 開始セル取得("顧客登録").Column
'顧客登録の開始列位置を取得
'顧客番号が未入力は処理終了
If IsEmpty(シート取得("顧客登録").Cells(r2, c2 + 1)) Then
Call マクロ終了処理
Exit
Sub
End If
With シート取得("顧客一覧")
'顧客登録の顧客番号で、顧客一覧の顧客番号を検索
Set rngFind =
.Range(.Cells(r1 + 1, c1), .Cells(.Cells.SpecialCells(xlLastCell).Row, c1))
_
.Find(What:=シート取得("顧客登録").Cells(r2, c2 + 1),
_
After:=.Cells(r1 + 1, c1), _
LookIn:=xlFormulas,
_
LookAt:=xlWhole, _
SearchOrder:=xlByColumns,
_
SearchDirection:=xlNext, _
MatchCase:=False,
_
MatchByte:=False)
If rngFind Is Nothing Then
'見つからなかった場合
MsgBox "指定の" & シート取得("顧客登録").Cells(r2, c2) &
"は存在しません。" & vbLf & vbLf &
_
"新規登録となります。", vbOKOnly
Call
マクロ終了処理
Exit Sub
End If
r0 = rngFind.Row
'検索された行
Do Until IsEmpty(.Cells(r1, c1))
'顧客一覧の見出し列の終わりまで
'顧客登録←顧客一覧
シート取得("顧客登録").Cells(r2, c2 + 1) =
.Cells(r0, c1)
c1 = c1 + 1 '顧客一覧の列を右に
r2 = r2
+ 2 '顧客登録の行を2つ下に
Loop
End With
Call マクロ終了処理
End Sub
修正箇所を太字にしています。
バグについて
r1 = rngFind.Rowとなっていましたので、
IsEmpty(.Cells(r1, c1)) において、
検索された行を使い空白セルの判定をしていました。
途中の列に未入力があると、それ以降のデータが取得されません。
そこで、新たに、変数r0を定義し、
r0 = rngFind.Row 変更としました。
そして、実際にデータ取得する行において、このr0を使用しています。
あくまで、r1は、見出し行の行番号として使うようにしています。
MsgBox "指定の" & シート取得("顧客登録").Cells(r2, c2) & "は存在しません。" &
vbLf & vbLf & _
"新規登録となります。",
vbOKOnly
メッセージを少し分かりやすく修正しました。
vbLfは、改行コードで、Chr(10)と同じです。
Chr関数は、指定したコードの文字を返します。
では新規Subモジュールとして、以下のコードを「Mod顧客登録」に貼り付けて下さい。
Sub 顧客一覧へ登録()
Dim r0 As Long '行番号ワーク
Dim r1 As Long, c1 As
Long '顧客一覧の見出しの行,列位置
Dim r2 As Long, c2 As Long '顧客登録の行,列位置
Dim
rngFind As Range 'Findの結果保存
Call マクロ開始処理
r1 = 開始セル取得("顧客一覧").Row '顧客一覧の開始行位置を取得
c1 =
開始セル取得("顧客一覧").Column '顧客一覧の開始列位置を取得
r2 =
開始セル取得("顧客登録").Row '顧客登録の開始行位置を取得
c2 = 開始セル取得("顧客登録").Column
'顧客登録の開始列位置を取得
'顧客番号が未入力は処理終了
If
IsEmpty(シート取得("顧客登録").Cells(r1, c1 + 1)) Then
MsgBox
シート取得("顧客登録").Cells(r2, c2) & "を入力して下さい。"
Call マクロ終了処理
Exit
Sub
End If
With
シート取得("顧客一覧")
'顧客登録の顧客番号で、顧客一覧の顧客番号を検索
Set rngFind =
.Range(.Cells(r1 + 1, c1), .Cells(.Cells.SpecialCells(xlLastCell).Row, c1))
_
.Find(What:=シート取得("顧客登録").Cells(r2, c2 + 1),
_
After:=.Cells(r1 + 1, c1), _
LookIn:=xlFormulas,
_
LookAt:=xlWhole, _
SearchOrder:=xlByColumns,
_
SearchDirection:=xlNext, _
MatchCase:=False,
_
MatchByte:=False)
If rngFind Is Nothing Then
'見つからなかった場合
r0 = .Cells.SpecialCells(xlLastCell).End(xlUp).Row +
1
Else
r0 = rngFind.Row '検索された行
End If
Do
Until IsEmpty(.Cells(r1, c1))
'顧客一覧の見出し列の終わりまで
'顧客登録←顧客一覧
.Cells(r0, c1) =
シート取得("顧客登録").Cells(r2, c2 + 1)
c1 = c1 + 1
'顧客一覧の列を右に
r2 = r2 + 2 '顧客登録の行を2つ下に
Loop
End With
シート取得("顧客一覧").Select '指定シートへ移る
Cells(r0,
開始セル取得("顧客一覧").Column).Select '開始位置の右横のセルを選択
Call マクロ終了処理
End Sub
Subモジュール、「顧客一覧より取得」とほぼ同様です。
変更箇所を太字にしています。
たったこれだけの変更で実現されています。
前回に書きましたが、いかにコードの使い回しが重要かということです。
If rngFind Is Nothing Then '見つからなかった場合
r0 =
.Cells.SpecialCells(xlLastCell).End(xlUp).Row + 1
Else
r0 = rngFind.Row
'検索された行
End If
「顧客一覧より取得」では、見つからなかった場合は、Exit
Subしていましたが、
今度のモジュールでは、新規登録となりますので、
一覧データの最終行を求めます。
.Cells.SpecialCells(xlLastCell)は使用している最終行です。
ここで使用しているというのは、データが入っているとは限らず、書式のみ設定してあるセルも含みます。
.End(xlUp)で、そのセルより上にデータのある行へ移動します。
.Rowは、その行ですね。
これは、Cells(Rows.Count, 1).End(xlUp).).Rowとする方が一般的だと思います。
あえて、.Cells.SpecialCells(xlLastCell)を使用してみました、お勉強です。
.Cells(r0, c1) = シート取得("顧客登録").Cells(r2, c2 +
1)
は、「顧客一覧より取得」と向きが逆なだけです。
「顧客一覧」→「顧客登録」と「顧客登録」→「顧客一覧」ですから、当たり前ですね。
シート取得("顧客一覧").Select
Cells(r0, 開始セル取得("顧客一覧").Column).Select
この2行で、更新した行の顧客番号のセルに移動します。
それでは、このマクロをファンクションに登録しましょう。
「顧客一覧」→「顧客登録」で使用した、で良いでしょう。
Sub ファンクションF1()
Dim strWork As String
Select Case True
Case ActiveSheet Is シート取得("顧客一覧")
If Not
IsEmpty(Cells(ActiveCell.Row, 開始セル取得("顧客一覧").Column)) And
_
ActiveCell.Row > 開始セル取得("顧客一覧").Row Then
strWork =
Cells(ActiveCell.Row, 開始セル取得("顧客一覧").Column)
Call
顧客登録シート作成
開始セル取得("顧客登録").Offset(0, 1) = strWork
Call
顧客一覧より取得
End If
Case ActiveSheet Is
シート取得("顧客登録")
Call 顧客一覧へ登録
End Select
End
Sub
特に説明は必要ないと思います。
F1を押されたシートが「顧客一覧」の場合に、Subモジュール「顧客一覧へ登録」を起動します。
同じテーマ「エクセル顧客管理」の記事
第8回.顧客一覧より顧客データを取得
第9回.イベントを使ってマクロを起動させる
第10回.コーディングとデバッグ
第11回.顧客登録より顧客一覧へ更新
第12回.最終行の判定、Rangeオブジェクトと配列、高速化の為に
第13回.コントロールのボタンを配置
第14回.オブジェクトとプロパティの真実(GW特別号No1)
第15回.記述による処理速度の違い(GW特別号No2)
第16回.処理速度の向上はどこまでやれば良い(GW特別号No3)
第17回.商品マスタを作成、2段階の可変リスト
第18回.納品書を作成、顧客情報を取得(1)
新着記事NEW ・・・新着記事一覧を見る
TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成|ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。|エクセル雑感(2024-02-17)
初級脱出10問パック|VBA練習問題(2024-01-24)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.繰り返し処理(For Next)|VBA入門
3.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
4.変数宣言のDimとデータ型|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.条件分岐(Select Case)|VBA入門
10.ブック・シートの選択(Select,Activate)|VBA入門
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。