登録する行の変更

質問

以下のコードで「入力」シートのデータから「DB]シートに登録するんです。「DB」シートの一行目A1は題名ですが新しいデータに入ってくるとどんどん題名は下の行に下がっていく。
題名は固定し、新しいデータはA2から入ってくるようにしたいですがどこに変更すればいいかわからなくて困っています。（ExcelのVBAはまったくわかりません）
よろしくお願いします。

Excel 2007
Sub 登録_Click()
'On Error GoTo Err_登録
Dim n As Integer '入力明細の数
Dim x As Long 'DBの検索範囲の最終行
Dim rng As Range '検索したセル
Dim z As Long 'DBのデータの最終行
Dim tbl As Worksheet '[ＤＢ]シート

Dim key As String '検索キー
Dim from_key As Long '更新範囲（自）
Dim to_key As Long '更新範囲（至）
'警告メッセージ非表示
Application.ScreenUpdating = False
Worksheets("入力").Activate
Set tbl = Sheets("ＤＢ")
z = tbl.Range("A1").CurrentRegion.Rows.Count
Check_登録:
key = Range("B2").Value
If key = "" Then
MsgBox "発注番号が未入力です。"
Exit Sub
End If

'[発注番号]でソート
tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess

'存在チェック
x = tbl.Range("A1").End(xlDown).Row
With tbl.Range("A1:A" & x)
Set rng = .Find(key, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rng Is Nothing Then
MsgBox "既存の番号が存在します。"
Exit Sub
End If
End With
'明細行有無チェック
n = WorksheetFunction.CountIf(Range("M46:M65"), "*")
If n = 0 Then
MsgBox "明細行がありません。"
Exit Sub
End If

Add_登録:
'空白行を省く
Selection.AutoFilter Field:=14, Criteria1:="<>"

'コピー&貼り付け
Range("A47:U66").Copy
tbl.Range("A" & z + 1).PasteSpecial Paste:=xlPasteValues

'[発注番号]でソート
tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess

'コピーモード解除
Application.CutCopyMode = False

'空白行を省くを解除
Selection.AutoFilter Field:=14

'ブック保存
'ActiveWorkbook.Save

'画面クリア
Call 画面クリア

'警告メッセージ表示
Application.ScreenUpdating = True

Exit_登録:
MsgBox "登録しました。"
Exit Sub

Err_登録:
MsgBox "エラーが発生しました

回答No.3

ap_2 · ベストアンサー

>>ANo.2
きっと他人が作ったプログラムの修正。貼るしかない気が…
ソースは確かに美しくないけどね；；

>>ANo.1
あれ、ANo.1じゃダメでした？それとも説明が悪かったかな。。
ダメでしたら、シートの構造と使い方の補足をお願いします。

◆ANo.1まとめ
VBA 24行目と51行目の2箇所を変更してみてください。
（修正前）1行目がタイトルか自動判別
　tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess
（修正後）1行目をタイトルとする
　tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlYes

◆＋α
質問とは別件ですが…
> '明細行有無チェック
> n = WorksheetFunction.CountIf(Range("M46:M65"), "*")
M46～M65のセルが、全部空ならエラーにする処理です。
多分、M47～M66の間違いかと。そうなら、"M47:66"に修正シテネ！

回答No.2

imogasi

こういう質問は、原データが無いので、チェックがしにくい。
どうせ丸投げするなら、文章でやりたいことを書いて質問してくれたほうが（丸投げだが）まだまし。
手本にした（あるいは質問者が弄り回したのかもしれないが）コードは、癖があって、どこかで見習った方法を、総動員した感じで、初心者向けには、勉強に適当ではないと思うし無駄があるように思う。。
（１）研作（未入力チェック
２）ソートーーＡ列に入っている、発注番号でらしい
（３）存在チェックーーＡ列で。存在チェックはＦｉｎｄでやってなぜ後半はＣｏｕｎｔＩＦ関数なのかな？
　　　存在チェックにその前のソートは効いているのかな（ソートする必要はあるのかな）
　　存在チェックそのものも不要に見えるが。
（４）空白行は除く
（５）ＤＢシートへの貼り付け
と処理が複雑だが
ーーー
エクセルもＶＢＡも判らないというなら、
Ｆｏｒ　Ｎｅｘｔで最初の行から最終行まで（1行ずつ）
ＩＦステートメントでその行の内容を判別する。そして
その行が条件に合わない行は処理せず（次の行の処理に移り）、
条件に合ったものは、ＤＢシートに１行分の列項目を代入（代入先行を１行ずつ、づらすテクニック要）
必要あれば最後にＤＢシートで並べ替え
の方法が、素直な考え方で、初心者むけだ。

回答No.1

ap_2

＃ぱっと見ただけなので、間違ってたらゴメンネですが…

> 'コピー&貼り付け
> Range("A47:U66").Copy
> tbl.Range("A" & z + 1).PasteSpecial Paste:=xlPasteValues
>
> '[発注番号]でソート
> tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlGuess

「入力」のA47:U66を、「DB」の一番 "下" に貼り付けてから、「DB」をA列でソートしてます。
たぶん、ここでタイトル行がデータ扱いされちゃってるんじゃないかな？

（修正）
> tbl.Range("A1").Sort Key1:=tbl.Range("A1"), Header:=xlYes

"Header:=xlGuess" 「タイトル行の有無を自動判別」 から、
"Header:=xlYes" 「先頭行をタイトルと見なす」 に・・・
ソート処理が2箇所あるので、両方とも変更してみてください。

ただ、コレが原因だとしたら、「自動判別できなくなった」のが問題な気がします。
プログラム作成当初とは何かが変わっているんじゃないでしょうか？
VBAを直すより、A列を見直してみる方がいいかもです。

お礼

ご回答ありがとうございます。
修正したやはり自動判別ができなくなって、入力したデータが混乱してしまいました。
そして、私の言い方が間違いました。A列はタイトルではなく1列はタイトルです。
エクセルは得意ではないですので、どこをどのように見直したらいいかわかならないです。
これは原因かもしれないという点があれば、是非教えて頂きたいです。
よろしくお願いします。