マクロかVBAについて

質問

あるExcelブックにあるデータがブックごとによってばらつきがあり困っております。
全てのブックの縦列にデータが入っていて項目名は一致しているのですが、
ブックによって並び順が異なります。

先日マクロの組み方で

Dim rng As Range, xTxt
For Each xTxt In Split("電話番号、住所、氏名、性別", "、")
Set rng = Rows(1).Find(xTxt, , xlValues, xlWhole)
If Not rng Is Nothing Then
rng.EntireColumn.Delete

上記の内容で不要な列を削除する方法を教えて頂き
うまくいったのですが、項目のキーが追加となり文字制限のようなもので
エラーが出てしまい困っております。※残したい項目以外の項目名が多すぎたのだと思います。

各ブックに入っている項目名(検索キー）は全て一致しているのですが、並びバラバラです。
項目名の数はおよそ100～200程でブックによって入っている項目と入っていないものがあります。
但し残したい項目名の数は約30前後

ただ、毎回ブックごとに並び順が変わる為できれば例えば、
(1)シート1のB列などにに項目名を縦にデータを入力し一覧にする。
(2)シート2に各ブックに入っている元データを貼り付け、シート１に入っている項目名以外のデータは項目名の列ごと削除
(3)最終的にはシート２にはシート１に入っている項目名のデータだけがのこる
そういったことが可能でしょうか。
よろしければ是非お力添えをお願い致します。

回答No.3

HohoPapa

>(1)シート1のB列などにに項目名を縦にデータを入力し一覧にする。
B列１行目から縦に列名が期待の順番に並んでいる前提
>(2)シート2に各ブックに入っている元データを貼り付け、
>シート１に入っている項目名以外のデータは項目名の列ごと削除
>(3)最終的にはシート２にはシート１に入っている項目名のデータだけがのこる
必要な列だけを期待の順番にコピペする動作。

以上の条件で作ってみました。

Option Explicit

Sub Sample()

　Dim GetFilePath As String
　Dim GetBook As Workbook
　Dim GetSheet As Worksheet
　Dim TblSheet As Worksheet
　Dim PutSheet As Worksheet
　Dim RowCouter As Long
　Dim ColCouter As Long
　Dim ColNum As Long
　Dim ColName As String

　'編集元ブックを選択して開く
　With Application.FileDialog(msoFileDialogOpen)
　　.InitialFileName = ThisWorkbook.Path
　　.Show
　　If .SelectedItems.Count = 0 Then
　　　MsgBox ("ファイルの選択がキャンセルされました。")
　　　Exit Sub
　　End If
　　GetFilePath = .SelectedItems(1)
　End With

　'出力先シートを自ブックに（２枚目として）追加
　ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(1)

　'ブック、シートを定義
　Set GetBook = Workbooks.Open(GetFilePath)
　Set GetSheet = GetBook.Sheets(1)
　Set TblSheet = ThisWorkbook.Sheets(1)
　Set PutSheet = ThisWorkbook.Sheets(2)

　RowCouter = 1　 '列並び一覧のデータ開始行

　'列ごとにコピペ
　Do
　　If TblSheet.Cells(RowCouter, 2).Value = "" Then Exit Do
　　ColName = TblSheet.Cells(RowCouter, 2).Value 'B列を順に取得
　　ColCouter = 1
　　ColNum = 0
　　Do
　　　If GetSheet.Cells(1, ColCouter).Value = "" Then Exit Do
　　　If ColName = GetSheet.Cells(1, ColCouter).Value Then
　　　　ColNum = ColCouter
　　　　Exit Do
　　　End If
　　　ColCouter = ColCouter + 1
　　Loop
　　If ColNum = 0 Then
　　　MsgBox ("列がありません:" & ColName)
　　Else
　　　GetSheet.Columns(ColNum).Copy
　　　PutSheet.Columns(RowCouter).PasteSpecial
　　End If
　　RowCouter = RowCouter + 1
　Loop

　'Application.DisplayAlerts = False
　GetBook.Close False　'編集元ブックをクローズ
　'Application.DisplayAlerts = True

End Sub

回答No.2

山田 太郎（@f_a_007）

【補足】データ型に応じて列をコピーするには？

　それは、質問者が知っているんじゃーないのかな。また、ここの回答者にとっては常識中の常識何では。もちろん、私は、しりません。でも、その手掛かりは提供できます。列名の次の行が、データのタイプです。これは、ADOの列タイプの番号に一致しています。回答者に、CopyDatas()を依頼される場合は、《データ型に応じて列をコピーする》も依頼されてください。

回答No.1

山田 太郎（@f_a_007）

Q、上記の内容で不要な列を削除する方法を教えて。
A、全く、逆の発想をしたら。

【不要な列を削除する】
　　↓
【必要な列をコピーする】

　これは、超簡単なVBAコードを書くだけで実現します。それだけではなくて、全体の列の並びも統一することが可能。必要であれば、年月日で昇順に並べてコピーすることもOK。たった、10分から20分で書けるであろうVBAを書くだけ。質問者が掛けなきゃー、幾らでも、そのコードを提供する回答者はわんさかいると思いますよ。

《果たしてそんなことが可能か？》

　添付図を一瞥して下さい。これは、[Sheet9$A1:Z1000]のデータを検索して、指定された列の列名とデータとを取得するテストです。各列データは";"で区切られています。仮に、";"を含むデータがあれば、"|"を指定します。この取得したデータを、行単位で配列に取り込んで、その後に各行を順次に取り出し、各列毎に取り出してシートに書き出す。これで、【必要な列をコピーする】は達成出来ます・

　で、仮に CopyDatas()という関数を作ったとして、変えるのは

DSelect("SELECT 列1,列2,列5,列6 FROM [Sheet9$A1:Z1000]",,chr(13))

の”Sheet9”だけ。もちろん、自分以外の外部のブックも指定できるように作成していますが、未テストです。

　ということで、「全く、逆の発想をしたら。！」ってのが私の回答です。