teratail
回答率
85.47%
質問するログイン新規登録

質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう！

新規登録して質問してみよう
ただいま回答率
85.47%
トップVBAに関する質問
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

データベース設計

データベース設計はデータベースの論理的や物理的な部分を特定する工程です。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

Q&A

解決済

2回答

1696閲覧

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

stinky
stinky

総合スコア2

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

データベース設計

データベース設計はデータベースの論理的や物理的な部分を特定する工程です。

マクロ

定義された処理手続きに応じて、どのような一連の処理を行うのかを特定させるルールをマクロと呼びます。

0グッド

0クリップ

投稿2020/10/02 05:48

編集2020/10/05 08:19

0

0

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

前提・実現したいこと

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

wb.Names("データシート").RefersTo
1wb.Activate
2ws.Select
3ws.Cells(ws.Rows.Count, 2).End(xlUp).Offset(1, 0).Select
4Application.DisplayAlerts = False
5wb.Save
6Application.DisplayAlerts = True
7wb.Close False
8コード

利用手順
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
コード

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

meg_
meg_

2020/10/02 06:25

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

回答2件

0

VBA
1'Set myRange = Application.Intersect(dataTable.SpecialCells(xlCellTypeVisible), dataTable.Rows("2:" & dataTable.Rows.Count))
2
3Set myRange = Application.Intersect(DataTable.SpecialCells(xlCellTypeVisible), DataTable.CurrentRegion.Offset(1, 0))
4

投稿2020/10/05 08:38

kuma_kuma_
kuma_kuma_

総合スコア2506

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

stinky
stinky

2020/10/05 13:49

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

0

ベストアンサー

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

ここがおかしいのですが

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

投稿2020/10/02 07:07

編集2020/10/02 07:47
kuma_kuma_
kuma_kuma_

総合スコア2506

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

stinky
stinky

2020/10/02 07:45

お返事ありがとうございます。 ご指摘の箇所は、ブック１のシート名"入力フォーム"になります。 使用しているのは ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム ブック２＝ブック名：データシート.xlsm、シート名：データシート 情報が不足し申し訳ございません。
kuma_kuma_
kuma_kuma_

2020/10/02 07:56

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

2020/10/02 08:35

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

2020/10/05 08:12

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

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。

15分調べてもわからないことは
teratailで質問しよう！

ただいまの回答率
85.47%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問

トップVBAに関する質問

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