Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
共有サーバ上のブックからデータを転記
投稿日時: 20/10/02 23:03:35
投稿者: VBA超初心者

VBA 初心者で勉強中です。
急遽管理表を作成することになりました。
ネットで調べながら構築していますが煮詰まっています。
申し訳ございませんがご助言ご教示お願いいたします。
 
仕様として、2つブックを用意し、1つは入力フォーム用ブック、2つ目はデータ蓄積のデータベース用ブック。
・ブック1=ブック名:入力フォーム.xlsm、シート名:入力フォーム
・ブック2=ブック名:データシート.xlsm、シート名:データシート
・ブック1はコピーし複数人で利用します。(複数の入力フォームブックで作成したデータを、逐一データベース用のブックに蓄積していき、必要に応じて呼び出す)
 
利用手順
A.ブック1、入力フォームのセルにブック2に転記したい内容をコマンドボタン「転記」にて、ブック2、データ蓄積のデータベースブックに転記する。
ブック1セルJ2は通し番号になっており、ブック2のA列に転記されていく
他転記したい内容のセルも其々ブック2のB列〜AM列に転記される
 
データシートに転記する際は、ブック2のA〜M、AH〜AM列に転記されるブック1のセルは各1箇所で、ブック2のN〜AG列は其々違います。
ブック1で入力されている内容(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)を転記すると下のブック2イメージのように転記されます。
例).ブック2のA〜M、AH〜AM列は同じ(A71984〜A71987は同じ)N〜AGは違う(N71984〜N71987は其々違う)
 
ブック2イメージ、入力範囲は名前の定義:データシート
行\列 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
 
 ※ブック1からブック2へデータを転記し蓄積するたび、ブック2は以下コードで定義を更新しています。
 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.ブック1の指定セル(ここではJ1)にブック2のA列の通し番号を入力し、
呼び出しのマクロを開始すると、ブック1にブック2の内容が呼び出しされる。
 
★以下、実現(構築)したいこと★
ブック1のセル「J1」に通しNo.の「9」を入力し、ブック2のA列を参照し、該当データをブック1へ呼び出す(転記)
ブック2からブック1へ呼び出されたデータ(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)
 
以下コードのように、ブックを1つで2シート(入力フォームシート、データシートシート)での作成では呼び出し(転記)ができました。
 
このコードを応用してブックを分けても同様の呼び出し(転記)ができないものでしょうか。
 
ブック名:入力フォーム.xlsm、シート名:sheet1="入力フォーム"、sheet2="データシート"
・sheet1の指定されたセルに入力し、マクロを使用しsheet2に転記
 ※転記後のイメージは上記「ブック2イメージ」と同じです
 
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 'データシート2列目を入力フォームJ8に転記
Range("J9").Value = myRange.Cells(3).Value 'データシート3列目を入力フォームJ9に転記
Range("I7").Value = myRange.Cells(4).Value 'データシート4列目を入力フォームI7に転記
Range("I1").Value = myRange.Cells(5).Value 'データシート5列目を入力フォームI1に転記
Range("B2").Value = myRange.Cells(6).Value 'データシート6列目を入力フォームB2に転記
Range("B3").Value = myRange.Cells(7).Value 'データシート7列目を入力フォームB3に転記
Range("B4").Value = myRange.Cells(8).Value 'データシート8列目を入力フォームB4に転記
'指定したフィールド(データシートsheet)を指定したセル位置(入力フォームsheet)に転記
For i = 0 To UBound(fieldList)
    myRange.Columns(fieldList(i)).Copy Range(rangeList(i))
Next
dataTable.AutoFilter 'フィルタ解除
End Sub

回答
投稿日時: 20/10/03 06:01:28
投稿者: simple

質問の焦点は何でしょうか?
 
今までは、同一のブック内の中で、シート間の転記を扱ってきたが、
これをブック間の転記に拡げたい、ということですね?
 
それなら、

    '検索元テーブルセット(range"データシート"は名前の定義)
    Set dataTable = Sheets("データシート").Range("データシート")
のところを、
    Set wb = Workbooks.Open(ブックのpathを指定します)
    Set dataTable = wb.Sheets("データシート").Range("データシート")

などとすれば、あとは従来と同様にできるのではないですか?
 
その他に懸念点はありますか?
共有サーバー上にあることに起因する特別な点があるか、という確認ですか?
そのBookを他人が使っている場合にはどうなりますか?
環境のことなので、これは質問者さんのほうが詳しいでしょう。
 
具体的に詰まっていることに絞って、またそれを明確にして質問して下さい。

投稿日時: 20/10/03 08:14:32
投稿者: 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を見に行けてないのかなと思います。
エラー以降は進めていない状態ですので、エラー以降は未検証です。
 
>共有サーバー上にあることに起因する特別な点があるか、という確認ですか?
エラー箇所から、共有サーバー上のブックを見に行けてないと推測しています。
 
>そのBookを他人が使っている場合にはどうなりますか?
こちらは、自分で開いていたら閉じる、他人が開いていたらメッセージを表示するようにしています。
※コード参照願います。
 
>具体的に詰まっていることに絞って、またそれを明確にして質問して下さい。
上記で発生したエラーの回避、及びそれ以降の検証です。
 
同一ブックでできたコードが応用できれば良いのですが、
もし、応用が利かない場合は1から作らないといけないことも考えています。
 
以下、構築中のコード
 
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("データシート")
    '転記したいフィールドを指定(ブック2の指定の範囲をブック1に転記する)
    fieldList = Array(14, 15, 16, 17, 18, 20, 21, 22, 23, 24, 26, 27, 28, 29, 30, 31, 32, 33)
    '転記先のセル位置を指定(ブック1の各セルに転記)
    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

回答
投稿日時: 20/10/03 08:49:24
投稿者: simple

コピーのところ(rangeListの関係のみ)しか見ていませんが、こんな風な感じですか?

    '転記先のセル位置を指定(ブック1の各セルに転記)
    rangeList = Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16")
    
    '指定したフィールドを指定したセル位置に転記
    For i = 0 To UBound(fieldList)
        myRange.Columns(fieldList(i)).Copy ws.Range(rangeList(i))
    Next
エラー箇所は、Worksheetが Array関数なんか持っていませんし、
決まりを守っていないから当然です。

回答
投稿日時: 20/10/03 09:23:29
投稿者: WinArrow
投稿者のウェブサイトに移動

引用:

rangeList = ThisWorkbook.Worksheet.Array("B16", "C16", "D16", "E16", "F16", "H16", "I16", "J16", "K16", "L16", "N16", "O16", "P16", "Q16", "R16", "S16", "T16", "U16")
ここでエラーが発生

 
2つの間違いがあります。
1つ目
既に指摘があるように、WorkSheetオブジェクトに「Array」なんてプロパテイは存在しません。
Arrayで記述しているのは、セルですか?
 
2つ目
rangeListは、オブジェクト変数ですから、Set を使います。
 
3つ目:間違いではないが、連続したセル範囲を指定する場合は、個々のセルではなく、範囲で指定します。
 
以上を修正すると、↓のようなコードになります。
 
 Set rangeList = ThisWorkbook.Worksheet.Range("B16:U16")
 
この方がわかりやすいし、修正も簡単ですよね?
 
 
 

投稿日時: 20/10/03 10:08:45
投稿者: VBA超初心者

simpleさま
ありがとうございます。
今出先ですので取り急ぎお返事まで。
以下2点、後ほど試してみます。
   rangeList = Array
   myRange.Columns(fieldList(i)).Copy ws.Range(rangeList(i))

投稿日時: 20/10/03 10:22:13
投稿者: VBA超初心者

WinArrowさま
ありがとうございます。
今出先ですので取り急ぎお返事まで。
 
>1つ目
>既に指摘があるように、WorkSheetオブジェクトに「Array」なんてプロパテイは存在しません。
>Arrayで記述しているのは、セルですか?
セル(列)を指定しています。
転記される行により対応させようとしています。
 
ブック2イメージ、入力範囲は名前の定義:データシート
行\列 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
例).上記の場合、ブック1の各セルに転記されるのは、
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
 
↑このお返事でよろしいでしょうか。返事内容に相違がありましたら、理解力不足ですみません。
 
>2つ目
>rangeListは、オブジェクト変数ですから、Set を使います。
分かりました、試してみます。
 
>3つ目:間違いではないが、連続したセル範囲を指定する場合は、個々のセルではなく、範囲で指定します。
>以上を修正すると、↓のようなコードになります。
>Set rangeList = ThisWorkbook.Worksheet.Range("B16:U16")
範囲指定、基本中の基本でした。
 
ご指摘ありがとうございます。
後ほど検証してみます。

回答
投稿日時: 20/10/03 10:44:09
投稿者: WinArrow
投稿者のウェブサイトに移動

>このお返事でよろしいでしょうか。返事内容に相違がありましたら
 
単純に、コーディングミスを指摘しただけですから、
その先の処理内容まで、含まれていません。
 
そのような意味で、お返事の内容は理解できません。

回答
投稿日時: 20/10/03 10:55:35
投稿者: WinArrow
投稿者のウェブサイトに移動

処理のないようですが、
 
転送元セルのアドレスと転送先セルのアドレスの関連(規則性)を整理した方がよいでしょうね・・・・
 
その整理した内容(規則性)に基づいてコードを記述しないと、
手作業をそのままコード化(マクロの記録と同じ)したのでは、
応用も効かないし、変更/修正への対応が難しいと思います。
 
以下のコードは、まったくの手作業レベルのコードと考えます。(ワープロイメージ)

引用:
Range("J8").Value = myRange.Cells(2).Value 'データシート2列目を入力フォームJ8に転記
Range("J9").Value = myRange.Cells(3).Value 'データシート3列目を入力フォームJ9に転記
Range("I7").Value = myRange.Cells(4).Value 'データシート4列目を入力フォームI7に転記
Range("I1").Value = myRange.Cells(5).Value 'データシート5列目を入力フォームI1に転記
Range("B2").Value = myRange.Cells(6).Value 'データシート6列目を入力フォームB2に転記
Range("B3").Value = myRange.Cells(7).Value 'データシート7列目を入力フォームB3に転記
Range("B4").Value = myRange.Cells(8).Value 'データシート8列目を入力フォームB4に転記

回答
投稿日時: 20/10/03 13:34:05
投稿者: WinArrow
投稿者のウェブサイトに移動

処理の内容ですが・・・・の続き
 
コードを読みなおしてみたが、
転送元のレイアウトの説明がないし、
何をしたいのか、さっぱりわかりません。
 

回答
投稿日時: 20/10/04 06:13:09
投稿者: simple

シート間の対応関係についての記述が不明確なのでわかりにくいが、次のようになるのでは?
 

   Set ws = ThisWorkbook.Sheets("入力フォーム")

    と、"入力フォーム"シートが変数wsにセットされているとして、
    フィールド部分の転記は、次のようになるのではないですか?
 
   '"データシート"シートから"入力フォーム"シートへの転記(の一部)
    Dim ofst As Long
    Dim myRow As Range
    ofst = 0    '   12行目からのズレ
    For Each myRow In myRange.Rows
        For i = 0 To UBound(fieldList)
            myRow.Columns(fieldList(i)).Copy ws.Range(rangeList(i)).Offset(ofst)
        Next
        ofst = ofst + 1
    Next
    
    dataTable.AutoFilter    'フィルタ解除  

回答
投稿日時: 20/10/04 23:11:55
投稿者: simple

変数 ws は既に使っていたようなので、別の変数に変更して下さい。
正常に動作することを確認して投稿しています。
(データシートには別の変数を使っていて衝突はしていなかったので、重複に気がつかなかった)
 
ところで、ここも含めて少なくとも3カ所にマルチポストしていたようですね。
teratail,Excelの学校,moug の順ですか。
 
3カ所にマルチポストする理由は何ですか?
 
Excelの学校でもコメントを頂いているのに放置していますね。
折角時間を割いて下さっている方に失礼じゃないですか。
マルチポストしたうえ、放置するというのは自分勝手過ぎませんか?
 
私の回答も放置されているが、
このように放置するんだから、別に急いでいるということでもなさそう。
多くのところに質問しないと解決出来ないという高度な内容でもない。
単に説明が不十分で、説明が分かりにくいだけの話です。
 
マルチポストしたら、それぞれにしっかり対応しないといけないし、
解決したら、それぞれにその旨を連携する必要があります。
本人も手間がかかるだけです。
 
ということで、そもそもマルチポストそのものに否定的な意見の人も多いです。
私も必要性は余り感じません。今後に向けて再考してもらいたいですね。

回答
投稿日時: 20/10/05 09:07:43
投稿者: radames1000

引用:
ところで、ここも含めて少なくとも3カ所にマルチポストしていたようですね。
teratail,Excelの学校,moug の順ですか。

Yahoo知恵袋も追加で。

投稿日時: 20/10/05 11:08:23
投稿者: VBA超初心者

radames1000様
はい、中々解決できなく、色々なご意見を参考にしたく質問させていただいています。
自己都合ですが、急ぎの状況でどうしても作り上げたくご質問しています。
不快な思いをされたのでしたら申し訳ございません。

投稿日時: 20/10/05 11:25:31
投稿者: VBA超初心者

simple様
お返事ありがとうございます。
家庭の事情で確認が取れない状況でした。決して放置してた訳ではございません。
>3カ所にマルチポストする理由は何ですか?
自分の知識では解決できなく、色々な方のご意見を参考にしたいと思いました。
自己都合ですが、急ぎで作り上げたくご質問しています。
不快な思いをさせてしまい申し訳ございません。
 
>Excelの学校でもコメントを頂いているのに放置していますね。
>折角時間を割いて下さっている方に失礼じゃないですか。
>マルチポストしたうえ、放置するというのは自分勝手過ぎませんか?
理由はどうであれ、返事に時間が空いてしまった事は事実です。
申し訳ないという思い一心です。
 
>多くのところに質問しないと解決出来ないという高度な内容でもない。
>単に説明が不十分で、説明が分かりにくいだけの話です。
自分のレベルの低さを痛感しています。すみません。
 
>マルチポストしたら、それぞれにしっかり対応しないといけないし、
>解決したら、それぞれにその旨を連携する必要があります。
>本人も手間がかかるだけです。
おっしゃる通りです。
確認できる状態になり次第、全てに目を通させていただいています。
 
>ということで、そもそもマルチポストそのものに否定的な意見の人も多いです。
>私も必要性は余り感じません。今後に向けて再考してもらいたいですね。
貴重なご意見、はっきり言っていただいてありがとうございます。
今後質問方法を改めます。

投稿日時: 20/10/05 11:52:32
投稿者: VBA超初心者

WinArrow様
複数の回答ありがとうございます。10/3、10/4確認が取れず返事が遅くなりました。申し訳ございません。
>以下のコードは、まったくの手作業レベルのコードと考えます。
お恥ずかしながら低レベルですみません。
 
>処理のないようですが、転送元セルのアドレスと転送先セルのアドレスの関連(規則性)を整理した方がよいでしょうね・・・・
>その整理した内容(規則性)に基づいてコードを記述しないと、手作業をそのままコード化(マクロの記録と同じ)したのでは、応用も効かないし、変更/修正への対応が難しいと思います。
  
>以下のコードは、まったくの手作業レベルのコードと考えます。(ワープロイメージ)
引用:
Range("J8").Value = myRange.Cells(2).Value 'データシート2列目を入力フォームJ8に転記
Range("J9").Value = myRange.Cells(3).Value 'データシート3列目を入力フォームJ9に転記
Range("I7").Value = myRange.Cells(4).Value 'データシート4列目を入力フォームI7に転記
Range("I1").Value = myRange.Cells(5).Value 'データシート5列目を入力フォームI1に転記
Range("B2").Value = myRange.Cells(6).Value 'データシート6列目を入力フォームB2に転記
Range("B3").Value = myRange.Cells(7).Value 'データシート7列目を入力フォームB3に転記
Range("B4").Value = myRange.Cells(8).Value 'データシート8列目を入力フォームB4に転記
  
>コードを読みなおしてみたが、転送元のレイアウトの説明がないし、何をしたいのか、さっぱりわかりません。
転送元のレイアウトですが、ブック2のイメージになります。
説明不足で失礼しました。
今一度整理します。

回答
投稿日時: 20/10/06 06:46:12
投稿者: simple

引用:
変数 ws は既に使っていたようなので、別の変数に変更して下さい。
正常に動作することを確認して投稿しています。
と書いたうえで、コードを提示しているのに、まったく無視ですか。
他人が費やした時間など、あなたにとっては何事でもないわけですね。
本当にあきれます。
 
質問するということは、
それに対して寄せられたコメントに対して、
もれなく応対する義務を負うということなんですよ。
 
というのは、
質問者は、無償でコメントを得られるメリットを享受するわけですから、
その一方で、コメントされた内容を試して、その結果を報告することによって、
参加者全員に対して貢献をしてもらう、という仕組みなわけです。
 
そうしたことを果たさずに、自分の気に入ったものにだけ反応するのは、
質問者の風上に置けない自分勝手な人ということです。マナー違反です。
 
なお、「VBA超初心者」などと名乗るのも気がしれません。
Accessも使っていて、これだけのコードを書ける人が超初心者であるわけがない。
そう書けば、基本的なことから指摘してもらえるかもしれない、とか
不都合が仮にあっても、初心者だから許されるだろうとかいった、
言わば"甘えた気分"と"あざとさ"が見え隠れする。
よく指摘されることだが、今回は身を持って感じた。以上。

投稿日時: 20/10/06 09:58:13
投稿者: VBA超初心者

simple様
ご指摘の内容真摯に受け止めます。
貴重なお時間を使わせてしまい、また不快な思いをさせてしまい申し訳ございませんでした。
 
お聞き苦しい言い訳になりますが、Accessは他者が作成したのを使用し、この度Exelに移行することになりました。VBAに関しては先月より始めました。色々調べたり質問しながら見様見真似で構築しているので、自身で深く理解できていない部分があります。
この度は大変失礼いたしました。