[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数ブックの指定列を抽出し、新規ブックの１シートに横に並べて貼りつけ』（ケッタリー）
初めましてよろしくお願いいたします
以下の作業はマクロで対応可能と考えておりますが、コードが思いつきません、
コード作成に対して、情報が不足しているとは思いますが、ご教示をお願いいたします。
・作業フォルダ内に複数のエクセルブック
エクセルブック名称は先頭に５桁の通し番号があるが
一部に５桁の通し番号が同一で、それに続く文字列が異なるものがある
・エクセルブックは２シートで構成
・２シート目のシート名称はすべて同じ
作業フォルダに格納されている複数のエクセルブックの２シート目のB列を
抽出し、新規エクセルブックの１シート目に貼り付け
作業フォルダ内に並べられているブック名の順番で新規ブックの１シート目に
左からは貼り付けていく。
※２シート目のB列はフィルタがかかっている
フィルタはB列の値が0の場合に表示から外す
※２シート目のA列はA1に項目名称 A2に0 A3に1 A52に50
※Ｂ列は52行
生成イメージ
１行目はエクセルブック名称
２行目から抽出したＢ列を貼りつけ
Ａ Ｂ Ｃ Ｄ Ｅ
１１ブック名 ２ブック名１ ２ブック名２ ３ブック名
２２シート目Ｂ列のＢ１ ２シート目Ｂ列のＢ１
３２シート目Ｂ列のＢ２
４２シート目Ｂ列のＢ３
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
自分もとある掲示板で、この様に指導され、
今ではVBAを他人に教えるくらいまでになりました。
例えば、、、
・新規Excelファイルを開く
・作業フォルダ内のExcelファイルを1ずつ順番に開く
・開いたファイル名をA1セルに記入する
・開いたファイルの「○×△」というシート名のB列を新規で開いたファイルのA列に転記する
みたいな感じです。
（匿名） 2023/07/13(木) 10:15:55
Sub ExtractAndPaste()
Dim filePath As String
Dim fileName As String
Dim newWorkbook As Workbook
Dim targetSheet As Worksheet
Dim pasteRange As Range
Dim extractRange As Range
Dim cell As Range
' 作業フォルダのパスを取得
filePath = ThisWorkbook.Path & "\"
' 新しいブックを作成
Set newWorkbook = Workbooks.Add
' 新しいブックの1番目のシートを取得
Set targetSheet = newWorkbook.Sheets(1)
' フォルダ内の各ブックについて処理
fileName = Dir(filePath & "*.xlsx")
Do While fileName <> ""
' ブックを開く
Workbooks.Open (filePath & fileName)
' 2番目のシートのデータ範囲を取得
Set extractRange = Workbooks(fileName).Sheets(2).Range("B1:B52")
' フィルタがかかっている場合、フィルタを解除
If extractRange.AutoFilterMode Then
extractRange.AutoFilter
End If
' フィルタを設定
extractRange.AutoFilter Field:=1, Criteria1:="<>0"
' 抽出したデータを新しいブックに貼り付け
If targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column = 1 Then
' 1行目にブック名を貼り付け
targetSheet.Cells(1, targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column + 1).Value = fileName
' 2行目から抽出したデータを貼り付け
Set pasteRange = targetSheet.Cells(2, targetSheet.Cells(1, targetSheet.Columns.Count).End(xlToLeft).Column)
extractRange.SpecialCells(xlCellTypeVisible).Copy pasteRange
End If
' フィルタを解除
extractRange.AutoFilter
' ブックを閉じる
Workbooks(fileName).Close SaveChanges:=False
' 次のブック名を取得
fileName = Dir()
Loop
' 新しいブックを保存
newWorkbook.SaveAs filePath & "結果.xlsx"
' 新しいブックを閉じる
newWorkbook.Close SaveChanges:=False
MsgBox "処理が完了しました。"
End Sub
（ものは試し） 2023/07/13(木) 10:20:57
とはいえ、マクロで対応可能と判断するからには部分的には考えついているわけですよね？
とりあえず、何処で詰まっているのか現状のコードを示されてはどうでしょうか？
既に提案があるように【疑似コード】でもよいと思います。
■２
行・列を踏まえたレイアウトがないので、今一つピンと来ませんが↓は無理かもしれません
＞作業フォルダ内に並べられているブック名の順番で新規ブックの１シート目に左からは貼り付けていく
別途【作業フォルダ内に並べられているブック名の順番】とやら（またはその並び順ルール）を取得して【並び替え】をすることも考えたほうが良いかもしれません。
（もこな２） 2023/07/13(木) 10:28:56
■３
以下の情報から考えて、全部とは言いませんが多くの部分は【マクロの記録】で必要な命令を調べることができるとおもいます。
・作業フォルダ内に複数のエクセルブック ・複数のエクセルブックの２シート目のB列 ※２シート目のB列はフィルタがかかっている ※Ｂ列は52行 新規エクセルブックの１シート目に貼り付け 生成イメージ １行目はエクセルブック名称 ２行目から抽出したＢ列を貼りつけ
踏まえて、検証していませんが、ざっくりと組み立てると↓のような感じになるのではないでしょうか？
Sub 研究用()
Const フォルダパス As String = "C:\作業フォルダ\"
Dim ブック名 As String
Dim 出力列 As Long
Dim 出力SH As Worksheet
Set 出力SH = Workbooks.Add.Worksheets(1)
出力列 = 1
ブック名 = Dir(フォルダパス & "*.xks?")
Do Until ブック名 = ""
出力SH.Cells(1, 出力列).Value = ブック名
With Workbook.Open("フォルダパス" & ブック名)
.Worksheets(2).Range("B2:B52").Copy 出力SH.Cells(2, 出力列)
.Close
End With
出力列 = 出力列 + 1
ブック名 = Dir()
Loop
End Sub
"質問"であるなら、現状のコードを示して詰まっているところを具体的に聞いたほうが的確なアドバイスが得られやすくなりますし、作成依頼をしたいということならその旨はっきり書いておいた方が、回答者さんと気持ちのすれ違いがおきなくてよいとおもいます。
（もこな２） 2023/07/18(火) 09:56:28
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.