[[20190619134449]]　『逆参照にて抽出可能？』（事務）　ページの最後に飛ぶ

『逆参照にて抽出可能？』（事務）

book1（sheet1）

    A　　B　　　 C　　　　　　　D
1　001　 2　　●●工事　　001-2-●●工事(=A1&"-"&B1&"-"&C1)

book1（sheet2）
　　　　　A
1（住所）〇〇市〇〇町〇丁目
2（TEL） ***-***-****
3（受注先）凸凹コーポレーション
4（受注額）30,000
5（仕入先）瀬戸際工業
6（仕入額）15,000
7（利益）　15,000

マクロを組んで「sheet1のD1」のタイトル名にて名前を付けて保存を実行（ここまでは出来ました）
001-2-●●工事.xlsm
↑↑
book1のマクロ作業にてこのような工事別のファイルが何十個もあるとします。

【例】
001-2-●●工事.xlsm
002-5-▽▽工事.xlsm
003-3-★★工事.xlsm
004-1-□□工事.xlsm
005-2-▲▲工事.xlsm
　・
　・
　・

book2
データ抽出ファイル
　　　　　A　　　　　　　　B　　　　　　　　C　　　　　　　　D　　　　　　　　　E
1　001-2-●●工事　〇〇市〇〇町〇丁目　***-***-****　凸凹コーポレーション

　　　　F　　　　　G　　　　　　H　　　　I　
1　30,000　瀬戸際工業　15,000　15,000

といったように1行ごとに1物件の情報を抽出（参照？）したいのです。

出来上がっていくファイルを後から見に行ってデータ化なんて可能でしょうか？

＜使用 Excel：Excel2013、使用 OS：Windows10 ＞

 マクロを実行するブックを含む全てのブックが同一フォルダに保存されている。

 ということで

 Sub test()
     Dim myDir As String, fn As String, F As String, n As Long
     myDir = ThisWorkbook.Path & "\"
     fn = Dir(myDir & "*.xls")
     Do While fn <> ""
         If fn <> ThisWorkbook.Name Then
             n = n + 1
             F = "'" & myDir & "[" & fn & "]"
             Cells(n, 1).Formula = "=" & F & "sheet1'!d1"
             Cells(n, 2).Resize(, 7).FormulaArray = "=transpose(" & F & "sheet2'!a1:a7)"
         End If
         fn = Dir
     Loop
     With Cells(1).CurrentRegion
         .Value = .Value
     End With
 End Sub

（seiya） 2019/06/19(水) 16:58

seiyaさん！すごい！
出来ました！！！！感動です。

実行するとA1～H1まで上手く反映されました。
ただA2～H2まで全て「0」と表示されるのは何故なんでしょうか？
（事務まま） 2019/06/20(木) 10:18

 参照先が空白の場合は0になります。
 こちらに変更してください。

 Sub testx()
     Dim myDir As String, fn As String, F As String, n As Long
     myDir = ThisWorkbook.Path & "\"
     fn = Dir(myDir & "*.xls")
     Do While fn <> ""
         If fn <> ThisWorkbook.Name Then
             n = n + 1
             F = "'" & myDir & "[" & fn & "]"
             Cells(n, 1).Formula = "=if(" & F & "sheet1'!d1="""",""""," & F & "sheet1'!d1)"
             Cells(n, 2).Resize(, 7).FormulaArray = "=transpose(if(" & F & "sheet2'!a1:a7="""",""""," & F & "sheet2'!a1:a7))"
         End If
         fn = Dir
     Loop
     With Intersect(Cells(1).CurrentRegion.EntireColumn, ActiveSheet.UsedRange)
         .Value = .Value
     End With
 End Sub
（seiya） 2019/06/20(木) 11:36

出来ました！
ですが何度もすみません。

もっと情報量が多いデータをやってみました。
途中まで上手くいくのですが「値の更新」とファイルオープンが出て来ます。
全てキャンセルして終わらせてみると、無事データの抽出は終わっています。
そして一番下の段に参照の数だけ「#REF!」と表示されています。

下記の式を使っているのですが何か問題ありそうでしょうか？

Sub testx()

     Dim myDir As String, fn As String, F As String, n As Long
     myDir = ThisWorkbook.Path & "\"
     fn = Dir(myDir & "*.xlsm")
     Do While fn <> ""
         If fn <> ThisWorkbook.Name Then
             n = n + 1
             F = "'" & myDir & "[" & fn & "]"
             Cells(n, 1).Formula = "=if(" & F & "date'!eb6="""",""""," & F & "date'!eb6)"
             Cells(n, 2).Resize(, 267).FormulaArray = "=transpose(if(" & F & "date'!eg1:eg267="""",""""," & F & "date'!eg1:eg267))"
         End If
         fn = Dir
     Loop
     With Intersect(Cells(1).CurrentRegion.EntireColumn, ActiveSheet.UsedRange)
         .Value = .Value
     End With
 End Sub

（事務まま） 2019/06/20(木) 16:21

 >「値の更新」とファイルオープンが出て来ます。
 「シートの選択」ではないのですか？
 シート選択ならシート名が違っています。
（seiya） 2019/06/20(木) 16:46

シート名を「date」に変更しているのですが問題ありでしょうか･･･？(;^_^A
（事務まま） 2019/06/20(木) 17:06

 dateなら「シート選択」のダイアログボックスは表示されることは無いはずです。

 実際のシート名に余計なスペース等がありませんか？
（seiya） 2019/06/20(木) 17:10

余計なスペースありません(;_;
また、最後には無事抽出が終わっているのも不可解ですよね...
（事務まま） 2019/06/20(木) 17:18

 これで試してください。
 セルに数式が残りますので、数式バーでシート名を確認してください。

 Transposeで配列数式になっていますので、矢印キーでセルを選択すれば数式に影響ありません。

 Sub testx() 
     Dim myDir As String, fn As String, F As String, n As Long
     myDir = ThisWorkbook.Path & "\"
     fn = Dir(myDir & "*.xlsm")
     Do While fn <> ""
         If fn <> ThisWorkbook.Name Then
             n = n + 1
             F = "'" & myDir & "[" & fn & "]"
             Cells(n, 1).Formula = "=if(" & F & "date'!eb6="""",""""," & F & "date'!eb6)"
             Cells(n, 2).Resize(, 267).FormulaArray = "=transpose(if(" & F & "date'!eg1:eg267="""",""""," & F & "date'!eg1:eg267))"
         End If
         fn = Dir
     Loop
 End Sub
（seiya） 2019/06/20(木) 17:23

ペーストの状態が数式にちゃんとなりましたが、全く同じ症状でした　涙

抽出される側に問題があるのかしら｡｡｡？

また明日頑張ります。
お付き合いいただき本当に感謝致します<(_ _)>

（事務まま） 2019/06/20(木) 17:40

 下記コードはファイルを開いて各シートの名前を確認します。

 Dateシートが無ければ最後にメッセージを表示します。

 Sub testxx()
     Dim myDir As String, fn As String, n As Long, ws As Worksheet, flg As Boolean, msg As String
     myDir = ThisWorkbook.Path & "\"
     fn = Dir(myDir & "*.xls")
     Do While fn <> ""
         If fn <> ThisWorkbook.Name Then
             n = n + 1: flg = False
             With GetObject(myDir & fn)
                 For Each ws In .Worksheets
                     If UCase$(Trim$(ws.Name)) = "DATE" Then
                         ws.Range("eg6").Copy ThisWorkbook.Sheets(1).Cells(n, 1)
                         ws.Range("eg1:eg267").Copy
                         ThisWorkbook.Sheets(1).Cells(n, 2).PasteSpecial Transpose:=True
                         flg = True: Exit For
                     End If
                 Next
                 Application.CutCopyMode = False
                 If Not flg Then msg = msg & vbLf & fn
                 flg = False
                 .Close False
             End With
         End If
         fn = Dir
     Loop
     If Len(msg) Then MsgBox "下記のファイルに ""Date"" シートが見当たりません" & msg, vbCritical
 End Sub

（seiya） 2019/06/20(木) 18:03

seiyaさん
おはようござます！＾＾

早速やってみました！
「シートが見当たりません」のエラーメッセージは一切出ませんでした！
また無事に抽出できました！

ただ最後にエラーメッセージが出ます。
実行時エラー'432'
オートメーションの操作中にファイル名またはクラス名をみつけられませんでした。

デバックをクリックすると黄色マーカーのコードは以下の通りでした
With GetObject(myDir & fn)
（事務まま） 2019/06/21(金) 11:25

 デバッグモードになった時点での fn はどのようになっていますか？
 カーソルを fn　の上に移動（クリックではない）するとポップアップが表示されます。
（seiya） 2019/06/21(金) 11:31

今、再度チャレンジしたところ今度は途中で止まりまた同じエラーメッセージが出ました。
デバックをクリックすると「メモリが不足しています」と･･･
その他コードが表示され前回と同じ黄色マーカー
fnのポップアップは以下の通りでした

fn="～$◎masterdate.xlms

（現在開いているファイル名「◎masterdate.xlms」
（事務まま） 2019/06/21(金) 13:41

 Dir関数でそれが出てきますか...

 >         If fn <> ThisWorkbook.Name Then
 を
          If (fn <> ThisWorkbook.Name) * (Not fn Like "~$*") Then

 に変更してみてください。
（seiya） 2019/06/21(金) 14:05

行けました！
エラー一切出ず、行けました！
すごい！！！
涙でそうです。

seiyaさん何者ですか！？　笑
プログラマーですか？
本当にすごいです！ありがとうございました！
（事務まま） 2019/06/21(金) 14:22

 原因がわかってホッとしました。

 最初に提示したコードを同じく変更すればそちらも機能するはずです。
 どちらでも、好きな方を使用してください。
（seiya） 2019/06/21(金) 14:27

本当だ！出来ました！
しかも、最初のコードの方がサックリ抽出できるっぽいです。

ごめんなさい、ちょっと質問です。
金額の項目があるのですが（抽出後のデータ）5個の抽出が成功しました。

　　　IR
1　9540000
2　 480000
3　1.1E+07
4　1490000
5　1000000

何故、IRの3だけこの様な表記になってしまうのでしょうか。
セルの中味は10909091とキチンとした数字です。

（事務まま） 2019/06/21(金) 16:09

 セルの幅を広げるか、セルの書式を0に変更するかしてください。
 最初のコードはブックを開かないので速いはずです。
（seiya） 2019/06/21(金) 16:15

セルの幅を広げて解決しました。　笑
ごめんなさい単純なことでしたね｡｡｡

また分からないことがあったら教えて下さい。
この度は本当に本当にありがとうございました！
（事務まま） 2019/06/21(金) 16:55

コメント返信：

[ 一覧(最新更新順) ]

[[20190619134449]] 『逆参照にて抽出可能？』（事務） ページの最後に飛ぶ

[[20190619134449]]　『逆参照にて抽出可能？』（事務）　ページの最後に飛ぶ