ここから本文です

VBAに関する質問です。御教授をお願い致します。 やりたいことは以下です。 ①:...

アバター

ID非公開さん

2019/9/706:22:43

VBAに関する質問です。御教授をお願い致します。
やりたいことは以下です。

①:結果を集約するエクセルのsheet1に特定フォルダーにある任意選択したエクセルを開き、sheet1のB10からM13までをコピーする。

②:結果を集約するエクセルのsheet1のB10からM13に貼り付ける。
③:①を繰り返す。
④:②を繰り返すが値の貼り付け位置はB14からM17になるようにする。
以降、③,④を繰り返す。(張り付け位置はずらしていく)

というマクロを組みたいです。
御教授の方、宜しくお願い致しますm(_ _)m

閲覧数:
62
回答数:
2
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

30246kikuさん

2019/9/711:13:33

以下でどうなりますか

この方法は、
・シート名がわかっている
・取得範囲がわかっている
の場合に使える方法かと・・・

ファイルを開かずにデータを入手するので、かなり速いかと・・・

提示する記述は、
以下のものをベースに、複数ファイルを直接指定する様に変更したもの

他のエクセルブックからファイルを開かずにデー
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q142059655...

こまかめの説明は、以下を参照のこと

2013エクセル、複数のエクセルファイルから、決まったシートのセル
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q141738537...


今回用の確認手順

新規ブックを開いて、標準モジュールに以下を記述します
testData を実行し、確認用ファイルを作成します
その後、Samp1 を実行してみます

確認用ファイル 10 個を対象にした場合、結果は瞬時に・・・

どうなりますか

※ 確認されたのなら、
実際のファイル数・ファイルサイズ・処理時間等教えてください



Option Explicit

Dim vA As Variant

Public Function mymyVal(v As Variant)
   vA = v
End Function

Public Sub Samp1()
   Dim rng As Range
   Dim vF As Variant
   Dim sF As String
   Dim i As Long
   Const CF As String = "=mymyVal('{%1}[{%2}]Sheet1'!B10:M13)"

   With Application.FileDialog(msoFileDialogOpen)
      .Title = "対象ファイル選択"
      .AllowMultiSelect = True
      .FilterIndex = 3
      If (Not .Show) Then Exit Sub

      Application.ScreenUpdating = False
      With ThisWorkbook.Worksheets("Sheet1")
         Set rng = .Cells(Rows.Count, "B").End(xlUp).Offset(1)
         If (rng.Row < 10) Then Set rng = .Range("B10")
      End With

      For Each vF In .SelectedItems
         i = InStrRev(vF, "\")
         sF = Replace(CF, "{%1}", Left(vF, i))
         On Error Resume Next
         rng.Formula = Replace(sF, "{%2}", Mid(vF, i + 1))
         On Error GoTo 0
         rng.Resize(UBound(vA), UBound(vA, 2)).Value = vA
         Set rng = rng.Offset(UBound(vA))
      Next
      Application.ScreenUpdating = True
   End With
End Sub


' 確認用データ環境作成

Public Sub testData()
   Dim sPath As String, sFile As String
   Dim rng As Range, r As Range
   Dim sS As String
   Dim i As Long, n As Long

   With Application.FileDialog(msoFileDialogFolderPicker)
      .Title = "確認用ファイル作成フォルダ選択"
      If (Not .Show) Then Exit Sub
      sPath = .SelectedItems(1) & "\"
   End With

   sS = InputBox("何ファイル作成 ?", , 10)
   If (sS = "") Then Exit Sub
   n = Val(sS)
   If (n < 1) Then n = 1

   Application.ScreenUpdating = False
   With Workbooks.Add
      With Worksheets("Sheet1")
         Set rng = .Range("A1:Z30")
      End With
      For Each r In rng
         r.Value = "1_" & r.Address(False, False)
      Next
      sFile = "test001"
      Application.DisplayAlerts = False
      .SaveAs sPath & sFile, xlOpenXMLWorkbook
      Application.DisplayAlerts = True

      For i = 2 To n
         rng.Replace i - 1 & "_", i & "_", xlPart
         sFile = "test" & Format(i, "000")
         Application.DisplayAlerts = False
         .SaveAs sPath & sFile, xlOpenXMLWorkbook
         Application.DisplayAlerts = True
      Next
      .Close False
   End With
   Application.ScreenUpdating = True
End Sub

この回答は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜1件/1件中

よこまやさん

2019/9/710:52:43

やりたい事を書いたら作ってくれる所と考えておられませんか?
あなた自身ではどこまで出来るのですか?
20%以下なら動く物を例えここで得られたとしても修整も出来ず結局困るのはあなたです。
自らどこまでやったかを示して質問するのが妥当と思いますよ。
でないと答える方もどのレベルから説明すべきかわかりにくいから。

あわせて知りたい

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる