VBA セルの検索と条件分岐による転記②

Question

前提・実現したいこと

sheet2からsheet1へ転記する際、sheet2の名前をsheet2のｾﾙC1（製番）へ変更する。
その後、sheet2（セルC1名）内の転記項目（C1〜C4）を変更した場合もsheet1へ反映される。

狙い：sheet2を入力ﾌｫｰﾏｯﾄとして、ｼｰﾄｺﾋﾟｰをしてｾﾙC1（製番）毎にｼｰﾄを増やしていく管理をしたいと考えています。

!ジ説明](42a21a325925899341056140f35cc064.jpeg)説明](1ebba338c590e324c38982e904757735.jpeg)](82ca2f8f34f8289353c9510282a0c8f4.jpeg)

該当のソースコード

Sub 検索転記△2()
    Dim number As Range     '入力値
    Dim number2 As Range    '入力値2
    Dim number3 As Range    '入力値3
    Dim result As Range     '検索結果
    Dim lastline As Long    '最終行
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet

    Set ws1 = Worksheets("sheet1")
    Set ws2 = ActiveSheet  '追加項目
    Set number = ws2.Range("C2")
    Set number2 = ws2.Range("C3")
    Set number3 = ws2.Range("C4")
    
    ws2.Name = ws2.Range("C1") '追加項目
    
    lastline = ws1.Cells(Rows.Count, "B").End(xlUp).Row 'ｼｰﾄ1 B列のｾﾙ入力済最終行を定義

    Set result = ws1.Range(ws1.Cells(4, 2), ws1.Cells(lastline, 2)).Find(number, lookat:=xlWhole)
    'No列の開始行から最終行の範囲で検索する

    If result Is Nothing Then 'Rangeが「Nothing」である場合
       n = Cells(Rows.Count, "B").End(xlUp).Row + 1
       o = Cells(Rows.Count, "C").End(xlUp).Row + 1
       
       ws1.Range("B" & n).Value = number.Value 'ハイパーリンク
         ws1.Hyperlinks.Add _
          Anchor:=ws1.Range("B" & n), _
          Address:="", _
          SubAddress:=ws2.Name & "!A1", _
          TextToDisplay:="number"
       
       ws1.Range("C" & o).Value = number2.Value
       ws1.Range("D" & o).Value = number3.Value
             
    ElseIf Not result Is Nothing Then
        'Findの結果で取得されたRangeから行数を取得し、その行に書き込む
        ws1.Cells(result.Row, 2).Value = number.Value 'ハイパーリンク
          ws1.Hyperlinks.Add _
           Anchor:=ws1.Cells(result.Row, 2), _
           Address:="", _
           SubAddress:=ws2.Name & "!A1", _
           TextToDisplay:="number"
                       
        ws1.Cells(result.Row, 3).Value = number2.Value
        ws1.Cells(result.Row, 4).Value = number3.Value

    End If
    
    
    
End Sub

試したこと

sheet2をｱｸﾃｨﾌﾞｼｰﾄ選択して、名前を変更しましたが、ｼｰﾄ名変更後にはｴﾗｰにより、
転記が反映されなくなってしまった。
set ws2 = activesheets
ws2.name = ws2.range("C1")

Comments

[yureighost]

試したことの処理が貼っているソース内にないです。
反映させた物を貼ってください。

[jabe]

連絡ありがとうございます。
すいませんでした、コードと実行結果をアップさせていただきました。

画像の通り、sheet名は変更されるのですが、sheet1のB25へ転記されるはずが、B5へ転記されてしまいます。

Answer 1

製番）毎にｼｰﾄを増やしていく管理をしたい

↑これがコードに書いてなくないですか？

Sub test()
    Dim rngData As Range
    Dim rngContents As Range
    Dim rngTarget As Range
    Dim num As Long
    Dim ws As Worksheet

    Set rngData = Worksheets("Sheet2").Range("C1:C4")
    With Worksheets("Sheet1").Range("B3").CurrentRegion
        Set rngContents = Worksheets("Sheet1").Range("B3").CurrentRegion.Columns(1).Cells
    End With
    num = rngData(1)

    '//シートの作成//
    'シートの存在確認
    On Error Resume Next
    Set ws = Worksheets(CStr(num))
    On Error GoTo 0
    'なければ入力シートをシートコピー
    If ws Is Nothing Then
        With Worksheets
            rngData.Worksheet.Copy After:=.Item(.Count)
            Set ws = .Item(.Count)
        End With
        ws.Name = num
    End If

    '//目次の作成//
    'データの存在確認
    Set rngTarget = rngContents.Find(num, , , xlWhole)
    '無ければ一番下の次を取得
    If rngTarget Is Nothing Then
        Set rngTarget = rngContents(rngContents.Count + 1, 1)
    End If
    '目次に転記＆ハイパーリンク挿入
    rngData.Copy
    With rngTarget
        .PasteSpecial Transpose:=True
        .Worksheet.Hyperlinks.Add _
                Anchor:=.Cells, _
                Address:="", _
                SubAddress:=ws.Range("A1").Address, _
                TextToDisplay:=CStr(.Value)
    End With
End Sub

Comments

[jabe]

回答ありがとうございます。
試してみます。

Answer 2

問題はシート名を変えたことではなくて、
ActiveSheetとして取得できるようにSheet2からマクロを起動するようにしたことですね。

・・・
    If result Is Nothing Then 'Rangeが「Nothing」である場合
       n = Cells(Rows.Count, "B").End(xlUp).Row + 1
       o = Cells(Rows.Count, "C").End(xlUp).Row + 1
・・・

ここのB、C列の最終行を取得するコードはSheet1に転記する関係上、Sheet1で実行しないといけませんが、
WorkSheetオブジェクトが無指定だとActiveSheetが対象になるので、
Sheet2で実行されてしまっています。

・・・
    If result Is Nothing Then 'Rangeが「Nothing」である場合
       n = ws1.Cells(Rows.Count, "B").End(xlUp).Row + 1
       o = ws1.Cells(Rows.Count, "C").End(xlUp).Row + 1
・・・

このようにSheet1のWorkSheetオブジェクトを指定すれば問題なく動作します。

Comments

[jabe]

コード作成ありがとうございます。
実現させたい内容で動作する事が出来ました。

ｓｈｅｅｔ指定の大切さを理解しました。