Excelの列から検索して該当する行を別シートに転記するVBA

Question

Excelのuserformのtextboxに入力された番号をA列から検索して
該当する行を別シートに転記するVBAを教えてください。
A列の番号は昇順で並んでおり、同じ番号は最大10回続きます。
同じ番号ならB列からE列は列ごとに同じ文字が入ります。
1行目は項目名が入り、番号は２行目からです。

Sheet1
　　A　 B　C　D　E　 F　 G　 H　 I 　 J　 K
1
2　760　z　b　s　h　い　ろ　は　に　ほ　へ
3　760　z　b　s　h　と　ち　り　ぬ　る　を
4　760　z　b　s　h　わ　か　よ　た　れ　そ
5　761　x　n　d　j　あ　い　う　え　お　か
6　761　x　n　d　j　き　く　け　こ　さ　し
7　762　v　m　f　k　ぬ　ね　の　は　ひ　ふ　
8　762　v　m　f　k　へ　ほ　ま　み　む　め
9　762　v　m　f　k　も　や　ゆ　よ　ら　り　
10 762　v　m　f　k　る　れ　ろ　わ　を　ん
・
・
・

760番を検索・転記する場合、Sheet2 A列に下記のように転記したいです。
1行目～3行目までは空欄
4行目はSheet1 D列の文字
5行目はSheet1 E列の文字
6行目以降はSheet1 F列～K列を行列入れ替えて縦一列に

Sheet2
　  A　
1　
2　
3　
4　 s　　
5　 h
6　 い　
7　 ろ
8　 は
9　 に
10  ほ
11　へ
12　と
13　ち
14　り
15　ぬ
16　る
17　を
・　・
・　・
・　・

例えば次に762番を検索・転記する場合、Sheet2にある文字は全部削除されて
A列４行目から同じように転記したいです。

よろしくお願いいたします。

tatsumaru77 · Accepted Answer

＞もし検索した番号がなかった場合
＞該当番号がありませんというmsgboxを表示したいのですが
＞教えていただけますでしょうか。
以下のようにしてください。
No1のは破棄してください。

Private Sub CommandButton1_Click()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow As Long
    Dim srow As Long: srow = 0
    Dim erow As Long: erow = 0
    Dim row1 As Long
    Dim row2 As Long
    Dim sval As String
    If TextBox1.Value = "" Then Exit Sub
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    sh2.Cells.ClearContents
    maxrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    For row1 = 2 To maxrow
        sval = sh1.Cells(row1, "A").Value
        If sval = TextBox1.Value Then
            If srow = 0 Then srow = row1
            erow = row1
        End If
    Next
    If srow = 0 Then
        MsgBox ("該当番号がありません")
        Exit Sub
    End If
    sh2.Cells(4, "A").Value = sh1.Cells(srow, "D").Value
    sh2.Cells(5, "A").Value = sh1.Cells(srow, "E").Value
    row2 = 6
    For row1 = srow To erow
        sh2.Cells(row2, "A").Resize(6, 1).Value = WorksheetFunction.Transpose(sh1.Cells(row1, "F").Resize(1, 6))
        row2 = row2 + 6
    Next
End Sub

tatsumaru77 · Answer

マクロを実行するトリガーが不明なので、コマンドボタンをクリックされた時と仮定して、作成しました。
もし、トリガーが他の場合は、プロシージャ名をそのように変えてください。

Private Sub CommandButton1_Click()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow As Long
    Dim srow As Long: srow = 0
    Dim erow As Long: erow = 0
    Dim row1 As Long
    Dim row2 As Long
    Dim sval As String
    If TextBox1.Value = "" Then Exit Sub
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    sh2.Cells.ClearContents
    maxrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    For row1 = 2 To maxrow
        sval = sh1.Cells(row1, "A").Value
        If sval = TextBox1.Value Then
            If srow = 0 Then srow = row1
            erow = row1
        End If
    Next
    If srow = 0 Then Exit Sub
    sh2.Cells(4, "A").Value = sh1.Cells(srow, "D").Value
    sh2.Cells(5, "A").Value = sh1.Cells(srow, "E").Value
    row2 = 6
    For row1 = srow To erow
        sh2.Cells(row2, "A").Resize(6, 1).Value = WorksheetFunction.Transpose(sh1.Cells(row1, "F").Resize(1, 6))
        row2 = row2 + 6
    Next
End Sub

Excelの列から検索して該当する行を別シートに転記するVBA

＞もし検索した番号がなかった場合

マクロを実行するトリガーが不明なので、コマンドボタンをクリックされた時と仮定して、作成しました。

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング