共有サーバ上のブックからデータを転記する

Question

VBA 初心者で勉強中です。
急遽管理表を作成することになりました。
ネットで調べながら構築していますが煮詰まっています。
申し訳ございませんがご助言ご教示お願いいたします。

前提・実現したいこと

仕様として、２つブックを用意し、１つは入力フォーム、２つ目はデータ蓄積のデータベースブック。
・ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム
・ブック２＝ブック名：データシート.xlsm、シート名：データシート
・ブック１はコピーし複数人で利用します。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
・ブック１からブック２へデータを転記し蓄積するたび、ブック２は以下コードで定義を更新しています。

wb.Activate
ws.Select
ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0).Select
Application.DisplayAlerts = False
wb.Save
Application.DisplayAlerts = True
wb.Close False
コード

利用手順
A.ブック１、入力フォームのセルに転記された内容をコマンドボタン「転記」にて、ブック２、データ蓄積のデータベースブックに転記する。
ブック１セルJ2は通し番号になっており、ブック２のA列に転記されていく
転記したい内容のセルも其々ブック２に転記される
例).ブック２のA～M、AH～AM列は同じ（A71984～A71992は同じ）N～AGは違う（N71984～Ｎ71992は其々違う）
※上記Aは作成できました。

B.ブック１の指定セル（ここではJ1）にブック２のA列の通し番号を入力し、
呼び出しのマクロを開始すると、ブック１にブック２の内容が呼び出しされる。

以下、実現（構築）したいこと
例).ブック１のセル「J1」に通しNo.の「31」を入力し、ブック２のA列を参照し、該当データをブック１へ呼び出す（転記）
また、ブック２からブック１への呼び出しの際は「値のみ貼りつけ」で転記したいです。

↓【ブック２"データシート.xlsm"、シート名"データシート"】　蓄積されたデータシート
蓄積範囲A2～AM＊は増えた分名前の定義を更新しています。名前定義：データシート

↓【ブック１"入力フォーム.xlsm"、シート名"入力フォーム"】　呼び出し後のイメージ

発生している問題

ブック２からブック１へ転記する際、フィルターをかけ見出し以外を選択したいですが、見出し部分が転記されてしまいます。

エラーが発生せずどこが原因か分からないでいます。
おそらく以下コードが原因だと推測してるのですが、躓いています。

'見出し行を除いた可視セル範囲を選択
Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))

ThisWorkbook.Worksheets("入力フォーム").Range("A4").Value = myRange.Cells(7).Value   'ブック2フィルターされた7列目をブック1A4に転記
ThisWorkbook.Worksheets("入力フォーム").Range("C9").Value = myRange.Cells(36).Value  'ブック2フィルターされた36列目をブック1C9に転記
ThisWorkbook.Worksheets("入力フォーム").Range("C11").Value = myRange.Cells(35).Value  'ブック2フィルターされた35列目をブック1C11に転記
ThisWorkbook.Worksheets("入力フォーム").Range("K12").Value = myRange.Cells(34).Value  'ブック2フィルターされた34列目をブック1K12に転記
ThisWorkbook.Worksheets("入力フォーム").Range("K13").Value = myRange.Cells(38).Value  'ブック2フィルターされた38列目をブック1K13に転記
ThisWorkbook.Worksheets("入力フォーム").Range("F13").Value = myRange.Cells(39).Value  'ブック2フィルターされた39列目をブック1F13に転記

該当のソースコード

全コード

Sub 呼び出し()
   Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
    Dim wb As Workbook, ws As Worksheet
    Dim myPath As String, fn As String
    Dim j As Long
    
    myPath = "\共有サーバ\"
    fn = "データシート.xlsm"
    
    '自PCで（データシート）が開いていたら閉じる
    On Error Resume Next
    Set wb = Workbooks(fn)
    On Error GoTo 0
    If Not wb Is Nothing Then
        wb.Close False
    End If
    
    Application.DisplayAlerts = False
    Set wb = Workbooks.Open(Filename:=myPath & fn, Notify:=False)
    Application.DisplayAlerts = True
    
    If wb.ReadOnly Then
    MsgBox "他の人が作業中です。しばらく経ってから呼び出しし直してください。"
    wb.Close False
    Exit Sub
Else
    Set ws = wb.Sheets("データシート")
    wb.Activate
    ws.Activate
End If

Application.ScreenUpdating = False

    '検索値のセット（ブック１入力フォーム）
    tmpint = ThisWorkbook.Worksheets("入力フォーム").Range("J1").Text                   
    '検索元テーブルセット（データシートの名前の定義"データシート"）
    Set dataTable = wb.ws.Range("データシート")

    '検索値でオートフィルタ（ブック２データシート）
    dataTable.AutoFilter 1, tmpint
    
    '検索値がなければメッセージを表示して処理を抜ける
    Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
    If myRange.Cells.Count = myRange.Columns.Count Then
    
    MsgBox "該当するレコードはありませんでした"
    
    dataTable.AutoFilter
    Exit Sub
End If

'見出し行を除いた可視セル範囲を取得
Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))

ThisWorkbook.Worksheets("入力フォーム").Range("A4").Value = myRange.Cells(7).Value   'ブック2フィルターされた7列目をブック1A4に転記
ThisWorkbook.Worksheets("入力フォーム").Range("C9").Value = myRange.Cells(36).Value  'ブック2フィルターされた36列目をブック1C9に転記
ThisWorkbook.Worksheets("入力フォーム").Range("C11").Value = myRange.Cells(35).Value  'ブック2フィルターされた35列目をブック1C11に転記
ThisWorkbook.Worksheets("入力フォーム").Range("K12").Value = myRange.Cells(34).Value  'ブック2フィルターされた34列目をブック1K12に転記
ThisWorkbook.Worksheets("入力フォーム").Range("K13").Value = myRange.Cells(38).Value  'ブック2フィルターされた38列目をブック1K13に転記
ThisWorkbook.Worksheets("入力フォーム").Range("F13").Value = myRange.Cells(39).Value  'ブック2フィルターされた39列目をブック1F13に転記

    'フィルターをかけた後、ブック２の見出し除くセルN3からAG最下行を選択
    With ws
    With ws.Range("A1").CurrentRegion
    j = .Rows.Count
    .Range(.Cells(3, 14), .Cells(j, 33)).Copy
    End With
    End With
    'ブック１のセルB16に貼りつけ
    ThisWorkbook.Worksheets("入力フォーム").Range("B16").PasteSpecial (xlPasteValues)

dataTable.AutoFilter 'フィルタ解除
wb.Close False
Application.ScreenUpdating = True

End Sub

試したこと

以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
ですがブックを２つに分けた際上記の問題がでてしまいます。
ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"

Sub 呼び出し()
    Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
    Dim fieldList(), rangeList()
    '検索値のセット
    tmpint = Sheets("入力フォーム").Range("J1").Text
    '検索元テーブルセット（range"データシート"は名前の定義）
    Set dataTable = Sheets("データシート").Range("データシート")
    '転記したいフィールド（データシートsheet）を指定
    fieldList = Array(9, 10, 11, 12)                                    
    '転記先（入力フォームsheet）のセル位置を指定
    rangeList = Array("B12", "C12", "D12", "E12")                                

    '検索値でオートフィルタ
    dataTable.AutoFilter 1, tmpint
    
    '検索値がなければメッセージを表示して処理を抜ける
    Set myRange = dataTable.SpecialCells(xlCellTypeVisible)
    If myRange.Cells.Count = myRange.Columns.Count Then
    
    MsgBox "該当するレコードはありませんでした"
    
    dataTable.AutoFilter
    Exit Sub
End If

'見出し行を除いた可視セル範囲を取得
Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))

Range("I9").Value = myRange.Cells(2).Value   'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑI9に転記
Range("I6").Value = myRange.Cells(3).Value   'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑI6に転記
Range("I7").Value = myRange.Cells(4).Value   'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
Range("I1").Value = myRange.Cells(5).Value   'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
Range("C4").Value = myRange.Cells(6).Value   'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑC4に転記
Range("C5").Value = myRange.Cells(7).Value   'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑC5に転記
Range("C6").Value = myRange.Cells(8).Value   'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑC6に転記

'指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
For i = 0 To UBound(fieldList)
    myRange.Columns(fieldList(i)).Copy Range(rangeList(i))

Next
dataTable.AutoFilter 'フィルタ解除

End Sub
コード

Comments

[meg_]

> rangeListやThisWorkbook.Worksheet.Arrayの箇所でエラーが発生します。
具体的なエラーメッセージを掲載してください。

Answer 1

'Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))

Set myRange = Application.Intersect(DataTable.SpecialCells(xlCellTypeVisible), DataTable.CurrentRegion.Offset(1, 0))

Comments

[stinky]

ご回答ありがとうございます。
お返事遅くなりました。
>CurrentRegion.Offset(1, 0))
ご指摘の場所を修正しましたら転記できました。
このようなコードの記述、勉強になります。
ありがとうございます。

Answer 2

    rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16",  "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16") '転記先のセル位置を指定

ここがおかしいのですが

'転記先のセル位置を指定
ReDim rangeList(0 To 17) As Range
Set rangeList(0) = ThisWorkbook.Worksheets("入力フォーム").Range("B16")
Set rangeList(1) = ThisWorkbook.Worksheets("入力フォーム").Range("C16")
Set rangeList(2) = ThisWorkbook.Worksheets("入力フォーム").Range("D16")
Set rangeList(3) = ThisWorkbook.Worksheets("入力フォーム").Range("E16")
Set rangeList(4) = ThisWorkbook.Worksheets("入力フォーム").Range("F16")
Set rangeList(5) = ThisWorkbook.Worksheets("入力フォーム").Range("H16")
Set rangeList(6) = ThisWorkbook.Worksheets("入力フォーム").Range("I16")
Set rangeList(7) = ThisWorkbook.Worksheets("入力フォーム").Range("J16")
Set rangeList(8) = ThisWorkbook.Worksheets("入力フォーム").Range("K16")
Set rangeList(9) = ThisWorkbook.Worksheets("入力フォーム").Range("L16")
Set rangeList(10) = ThisWorkbook.Worksheets("入力フォーム").Range("N16")
Set rangeList(11) = ThisWorkbook.Worksheets("入力フォーム").Range("O16")
Set rangeList(12) = ThisWorkbook.Worksheets("入力フォーム").Range("P16")
Set rangeList(13) = ThisWorkbook.Worksheets("入力フォーム").Range("Q16")
Set rangeList(14) = ThisWorkbook.Worksheets("入力フォーム").Range("R16")
Set rangeList(15) = ThisWorkbook.Worksheets("入力フォーム").Range("S16")
Set rangeList(16) = ThisWorkbook.Worksheets("入力フォーム").Range("T16")
Set rangeList(17) = ThisWorkbook.Worksheets("入力フォーム").Range("U16")

Comments

[stinky]

お返事ありがとうございます。
ご指摘の箇所は、ブック１のシート名"入力フォーム"になります。

使用しているのは
ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム
ブック２＝ブック名：データシート.xlsm、シート名：データシート
情報が不足し申し訳ございません。

[kuma_kuma_]

使い方が間違っているのでこのままでは回答が書けません
※行番号,列番号　ともに数値型(Long)
.Cells(行番号,列番号)　’1セル選択
.Range("A1") ’複数セル選択(1セル可)
.Rows(行番号)　　　　’指定範囲の行選択
を参考に一度書き直してください。

[stinky]

ご指摘の内容で試してみます。

不足している情報を追記しました。すみません。
ブック２は、ブック１からデータ転記時にデータ範囲を名前の定義の更新をしています。

[stinky]

全体的に見直し、fieldList,rangeListを使用せず、一部分のブック２からブック１へ転記（コピー貼りつけ）ができました。
ですが、まだうまく転記できない部分が残ってしまいました。
「発生している問題」を修正いたしました。