[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『共有サーバ上のブックからデータを転記する』（vbaビギナー）
VBA 初心者で勉強中です。
急遽管理表を作成することになりました。
ネットで調べながら構築していますが煮詰まっています。
申し訳ございませんがご助言ご教示お願いいたします。
仕様として、２つブックを用意し、１つは入力フォーム用ブック、２つ目はデータ蓄積のデータベース用ブック。
・ブック１＝ブック名：入力フォーム.xlsm、シート名：入力フォーム
・ブック２＝ブック名：データシート.xlsm、シート名：データシート
・ブック１はコピーし複数人で利用します。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
利用手順
A.ブック１、入力フォームのセルにブック２に転記したい内容をコマンドボタン「転記」にて、ブック２、データ蓄積のデータベースブックに転記する。
ブック１セルJ2は通し番号になっており、ブック２のA列に転記されていく
他転記したい内容のセルも其々ブック２のB列〜AM列に転記される
データシートに転記する際は、ブック２のA〜M、AH〜AM列に転記されるブック１のセルは各１箇所で、ブック２のN〜AG列は其々違います。
ブック１で入力されている内容（J2=9, B2=S, B3=Q, B12=R, B13=E, B14=D, B15=K, C12=X, C13=A, C14=Z, C15=Y, D12=T, D13=Q, D14=M, D15=C, E12=V, E13=L, E14=V, E15=E, J8=P, J9=Z）を転記すると下のブック２イメージのように転記されます。
例).ブック２のA〜M、AH〜AM列は同じ（A71984〜A71987は同じ）N〜AGは違う（N71984〜Ｎ71987は其々違う）
ブック２イメージ、入力範囲は名前の定義：データシート
行＼列 A B … M N O P Q … AH AI…AG
71982 5 F S G E A T Y X
71983 5 F L W D T E Y X
71984 9 S Q R X T V P Z
71985 9 S Q E A Q L P Z
71986 9 S Q D Z M V P Z
71987 9 S Q K Y C E P Z
※ブック１からブック２へデータを転記し蓄積するたび、ブック２は以下コードで定義を更新しています。
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は作成できました。
B.ブック１の指定セル（ここではJ1）にブック２のA列の通し番号を入力し、
呼び出しのマクロを開始すると、ブック１にブック２の内容が呼び出しされる。
★以下、実現（構築）したいこと★
ブック１のセル「J1」に通しNo.の「9」を入力し、ブック２のA列を参照し、該当データをブック１へ呼び出す（転記）
ブック２からブック１へ呼び出されたデータ（J2=9, B2=S, B3=Q, B12=R, B13=E, B14=D, B15=K, C12=X, C13=A, C14=Z, C15=Y, D12=T, D13=Q, D14=M, D15=C, E12=V, E13=L, E14=V, E15=E, J8=P, J9=Z）
以下コードのように、ブックを１つで２シート（入力フォームシート、データシートシート）での作成では呼び出し（転記）ができました。
このコードを応用してブックを分けても同様の呼び出し（転記）ができないものでしょうか。
ブック名：入力フォーム.xlsm、シート名：sheet1="入力フォーム"、sheet2="データシート"
・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("J8").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ２列目を入力ﾌｫｰﾑJ8に転記
Range("J9").Value = myRange.Cells(3).Value 'ﾃﾞｰﾀｼｰﾄ３列目を入力ﾌｫｰﾑJ9に転記
Range("I7").Value = myRange.Cells(4).Value 'ﾃﾞｰﾀｼｰﾄ４列目を入力ﾌｫｰﾑI7に転記
Range("I1").Value = myRange.Cells(5).Value 'ﾃﾞｰﾀｼｰﾄ５列目を入力ﾌｫｰﾑI1に転記
Range("B2").Value = myRange.Cells(6).Value 'ﾃﾞｰﾀｼｰﾄ６列目を入力ﾌｫｰﾑB2に転記
Range("B3").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ７列目を入力ﾌｫｰﾑB3に転記
Range("B4").Value = myRange.Cells(8).Value 'ﾃﾞｰﾀｼｰﾄ８列目を入力ﾌｫｰﾑB4に転記
'指定したﾌｨｰﾙﾄﾞ（ﾃﾞｰﾀｼｰﾄsheet）を指定したｾﾙ位置（入力ﾌｫｰﾑsheet）に転記
For i = 0 To UBound(fieldList)
myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
Next
dataTable.AutoFilter 'フィルタ解除
End Sub
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
ブックを指定して試してみましたか。
（マナ） 2020/10/03(土) 07:25
仕様の補足として、ブック１はコピーし複数人で利用するように考えています。（複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す）
ブックを指定して試してみましたか。 はい、指定してみました。（うまくできてるか自信は無いですが）
そこで以下コードを構築しているところなのですが、
rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16")
ここでエラーが発生し、うまくブック２を見に行けてないのかなと思います。
エラー以降は進めていない状態ですので、エラー以降は未検証です。
同一ブックでできたコードが応用できれば良いのですが、
もし、応用が利かない場合は１から作らないといけないことも考えています。
以下、構築中のコード
Sub 呼び出し()
Dim tmpint As Variant, dataTable As Range, myRange As Range, i As Long
Dim fieldList()
Dim rangeList()
Dim wb As Workbook, ws As Worksheet
Dim myPath As String, fn As String
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
'検索値のセット
tmpint = ThisWorkbook.Worksheets("入力フォーム").Range("J1").Text
'検索元テーブルセット
Set dataTable = wb.ws.Range("データシート")
'転記したいフィールドを指定（ブック２の指定の範囲をブック１に転記する）
fieldList = Array(14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33)
'転記先のセル位置を指定（ブック１の各セルに転記）
rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16")
'検索値でオートフィルタ
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("B2").Value = myRange.Cells(2).Value 'ﾃﾞｰﾀｼｰﾄ2列目を入力ﾌｫｰﾑB2に転記
Range("A4").Value = myRange.Cells(7).Value 'ﾃﾞｰﾀｼｰﾄ7列目を入力ﾌｫｰﾑA4に転記
Range("C9").Value = myRange.Cells(35).Value 'ﾃﾞｰﾀｼｰﾄ35列目を入力ﾌｫｰﾑC9に転記
Range("C11").Value = myRange.Cells(34).Value 'ﾃﾞｰﾀｼｰﾄ34列目を入力ﾌｫｰﾑC11に転記
Range("K12").Value = myRange.Cells(33).Value 'ﾃﾞｰﾀｼｰﾄ33列目を入力ﾌｫｰﾑK12に転記
Range("K13").Value = myRange.Cells(37).Value 'ﾃﾞｰﾀｼｰﾄ37列目を入力ﾌｫｰﾑK13に転記
Range("F13").Value = myRange.Cells(38).Value 'ﾃﾞｰﾀｼｰﾄ38列目を入力ﾌｫｰﾑF13に転記
'指定したフィールドを指定したセル位置に転記
For i = 0 To UBound(fieldList)
myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
Next
dataTable.AutoFilter 'フィルタ解除
End Sub
（vbaビギナー） 2020/10/03(土) 08:21
（マナ） 2020/10/03(土) 08:36
> rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E1
↓
rangeList = Array("B16", "C16", "D16", "E1
では。
（マナ） 2020/10/03(土) 09:01
そもそもですが、オートフィルタでなく VlookupとかMatchで、検索のほうが簡単では？ １つのブックで動作したコードがあるので、１から構築するより応用できればと思いました。
ですが、うまく応用できなければMatchなどを利用し１から構築することも考えます。
エラーについては > rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E1
↓
rangeList = Array("B16", "C16", "D16", "E1 では。 当初上記で作成してましたが、同ブック（ブック２）内にコピー貼り付けされてしまいました。
そのためブック１を指定するのかと考えたところ、エラーで躓いている状態です。
また、rangeListの前にsetを記述する方法や、copyのところも原因かなと思いました。
myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
を
myRange.Columns(fieldList(i)).Copy ws.Range(rangeList(i))
試してみます。
今出先ですので後ほど検証してみます。
（vbaビギナー） 2020/10/03(土) 10:32
wsでなく、入力ﾌｫｰﾑでは？
（マナ） 2020/10/03(土) 10:44
Set wsデータ = wb.Sheets("データシート")
Set ws入力 = ThisWorkbook.Sheets("入力フォーム")
Set dataTable = wsデータ.Cells(1).CurrentRegion
Dim m
m = Application.Match(ws入力.Range("J1"), dataTable.Columns(1), 0)
If IsError(m) Then
MsgBox "該当するレコードはありませんでした"
Exit Sub
End If
Set myRaneg = dataTable.Rows(m)
For i = 0 To UBound(fieldList)
myRange(fieldList(i)).Copy ws入力.Range(rangeList(i))
Next
（マナ） 2020/10/03(土) 11:13
でした。たぶん。
（マナ） 2020/10/03(土) 13:08
移動された様です https://www.moug.net/faq/viewtopic.php?t=79864 （SoulMan） 2020/10/03(土) 18:44
https://teratail.com/questions/295468
（マナ） 2020/10/04(日) 09:54
＞ myRange.Columns(fieldList(i)).Copy ws.Range(rangeList(i)) wsでなく、入力ﾌｫｰﾑでは？ そうでした。"入力フォーム"でした。
貼りつけはできましたが、wsに貼ってしまい失敗でした。
しかも貼りつけできたのは16行目のみになってしまいました。
ブック１入力フォームsheetの各B16,B17…C16,C17…にできれば良いのですが。
はいオートフィルタで試しています。
試行錯誤してみます。
（vbaビギナー） 2020/10/05(月) 11:00
simpleさんの回答は試していないのですか。
（マナ） 2020/10/05(月) 22:58
Sub test2()
Dim データWS As Worksheet
Dim 入力WS As Worksheet
Dim 全データ As Range
Dim 検索範囲 As String
Dim 通しNo As Long
Dim 抽出列 As String
Dim 条件列 As String
Set データWS = Worksheets("Sheet1")
Set 入力WS = Worksheets("Sheet2")
Set 全データ = データWS.Columns(1).SpecialCells(xlCellTypeConstants)
検索範囲 = 全データ.Columns("A:AM").Address(external:=True)
通しNo = 入力WS.Range("J1").Value
入力WS.Range("B2").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",2,0),"""")"
入力WS.Range("A4").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",7,0),"""")"
入力WS.Range("C9").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",35,0),"""")"
入力WS.Range("C11").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",34,0),"""")"
入力WS.Range("K12").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",33,0),"""")"
入力WS.Range("K13").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",37,0),"""")"
入力WS.Range("F13").Formula = "=iferror(vlookup(" & 通しNo & "," & 検索範囲 & ",38,0),"""")"
抽出列 = 全データ.Columns("N:AG").Address(external:=True)
条件列 = 全データ.Columns("A").Address(external:=True)
With 入力WS.Range("B16:U25") '転記先
.ClearContents
.Range("A1").Formula2 = "=Filter(" & 抽出列 & "," & 条件列 & "=" & 通しNo & ","""")"
.Value = .Value
End With
End Sub
（マナ） 2020/10/06(火) 17:04
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.