エクセルVBAで別ブックへ個別番号付きデータをコピーしたい。重複判断で新規or上書きしたい

Question

エクセルで個別のブックで工事種別、金額、納期、担当者等
書き込んだ内容を別ブックの一覧に登録したいです。
個別の番号で管理していますが都度コピーして貼り付けしています。
以前貼り付けたかどうかは番号検索して確認しています。
新規に登録するプログラムはなんとか前任者のデータを改変して
できました。
書き込んで保存して元のブックに戻って来ることまでできましたが、
重複を確認できません。

・個別番号含む必要データをコピーする
※（個別番号を取得）
・登録用ブックへ飛ぶ
※（個別番号が既にあれば上書き、無ければ新規に）
・データ最下段へペーストする（無理やり最下段取得しています）
・上書き保存する
・個別ブックへ戻る
・"登録済"を表示

※の実装をしたいです。

現在は

Sub 自動台帳登録1()
ActiveWindow.SmallScroll ToRight:=0
Range("O14:AF14").Select
Selection.Copy
ChDir "\Hdr-landisk\共有\工事張"
Workbooks.Open Filename:="\Hdr-landisk\共有\工事張\工事台帳.xls"
Range("C8").End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlDown).End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues
ActiveWorkbook.Close SaveChanges:=True
ThisWorkbook.Activate
Range("n7") = "登録済"

End Sub

よろしくお願いします。

Answer 1

こんな感じでどうでしょうか。

    Dim rng As Range, arr As Variant, id As String
    Set rng = ActiveSheet.Range("O14:AF14")
    arr = rng.Value
    id = arr(1, 1)
    
    Dim colC As Range, dest As Range
    With Workbooks.Open(Filename:="\Hdr-landisk\共有\工事張\工事台帳.xls")
        Set colC = .Worksheets(1).Columns(3)
        If WorksheetFunction.CountIf(colC, id) = 0 Then
            Set dest = colC.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        Else
            Set dest = colC.Cells(WorksheetFunction.Match(id, colC, False), 1)
        End If
        dest.Resize(1, UBound(arr, 2)).Value = arr
        .Close SaveChanges:=True
    End With
    rng.Worksheet.Range("N7") = "登録済"

Comments

[takagi8726]

回答ありがとうございます。
だめでした。
コピーしたい場所の取り込みと”登録済”の書き込みは
戻ってきましたが台帳は新規にも上書きにもなりませんでした。

重要な情報を忘れていました。
個別ブックの個別番号はO14に入っています。
登録先の台帳はC列に個別番号が入ります。
すみません。引き続きお知恵をお貸しください。

[jinoji]

登録台帳にはシートが複数ありますか？

[takagi8726]

あります。
工事台帳ブックを開くと工事台帳シートが開きますが、
前に3つ後に6つの別件シートがあります。
工事台帳ブックを開いたら工事台帳シートに行けてしまっていたので
気にしていなかったです。

番号の重複は検出していて重複番号置いておくとマクロが工事台帳で止まります。

[jinoji]

Set colC = .Worksheets(1).Columns(3) のところを
Set colC = .Worksheets("工事台帳シート").Columns(3) に変えてください。

（意図と違ったシート（１シート目）に書き出されてしまっていると思います。）

[takagi8726]

できました。ありがとうございます。

Dim rng As Range, arr As Variant, id As String
Set rng = ActiveSheet.Range("O14:AF14")
arr = rng.Value
id = arr(1, 1)

Dim colC As Range, dest As Range
With Workbooks.Open(Filename:="\Hdr-landisk\共有\工事張\工事台帳.xls")
Set colC = .Worksheets("工事帳").Columns(3)
If WorksheetFunction.CountIf(colC, id) = 0 Then
Set dest = colC.Cells(Rows.Count, 1).End(xlUp).Offset(1)
Else
Set dest = colC.Cells(WorksheetFunction.Match(id, colC, False), 1)
End If
dest.Resize(1, UBound(arr, 2)).Value = arr
.Close SaveChanges:=True
End With
rng.Worksheet.Range("N7") = "登録済"

しばらく運用してみます。
助かりました。これで私だけ少し早く帰れます。
内容を理解してその先もがんばってみます。
またよろしくお願い致します。