エクセル2007 VBA シート内のデータを項目名で検索し、その列を新

質問

エクセル2007 VBA シート内のデータを項目名で検索し、その列を新規シートにコピーする方法についてです。
VBAについては初心者で、グーグルで調べながら作ったのですが、コピー後のペーストが上手く出来ません。どうすれば最後まで処理できるのかを教えて下さい。
それと、全体的に書き方がおかしいところがありましたら指摘・改善方法を教えて下さい。
よろしくお願いします。

Sub 配列並べ替え()

Dim myArray As Variant '１項目名希望順配列格納
Dim strArray As Variant '２検索用１の配列格納
Dim LastCol1 As Long '３最終列数格納
Dim LastCol2 As Long '４新規シートの最終列数格納
Dim DefSheetname As Variant '５初期のシート名取得
Dim i As Long
Dim j As Long

'初期シート名を取得。
DefSheetname = ActiveSheet.Name

'初期シートの最終列数取得。
LastCol1 = Worksheets(DefSheetname).Range("A1").End(xlToRight).Column

'シート名：レポートの新規シート追加。
Worksheets.Add.Name = "レポート"

'初期シートを選択。
Worksheets(DefSheetname).Select

'項目名希望順配列格納。
myArray = Array("得意先C", "取引先名1", "製番", "相手管理NO", "品目C", _
"製品名1", "受注数", "受注残数", "納期", "受注単価", _
"受注金額", "出荷数", "出荷金額", "出荷先名1", "郵便番号", "住所1", "TEL", "FAX")

'配列要素数分繰り返し処理。
For i = LBound(myArray) To UBound(myArray)

'検索用の配列(項目名)格納。
strArray = myArray(i)

'A1:LastCol1範囲で配列(項目名)検索し、番号で返す。
j = WorksheetFunction.Match(strArray, Worksheets(DefSheetname).Range(Cells(1, 1), Cells(1, LastCol1)), 0)

'シート名：レポートに変数jの列数目の値を入力。
Columns(j).Copy

'シート名：レポートの最終列数取得。
LastCol2 = Worksheets("レポート").Range("A1").End(xlToRight).Column

'シート名：レポートを選択。
Worksheets("レポート").Select

Range(Cells(1, 1), Cells(1, "LastCol2")).Past

Next i

End Sub

回答No.1

end-u · ベストアンサー

現在のコードで取り敢えず動くようにするなら

Sub 配列並べ替え()
　Dim myArray　　　As Variant '１項目名希望順配列格納
　Dim strArray　　 As Variant '２検索用１の配列格納
　Dim LastCol1　　 As Long　　'３最終列数格納
　Dim LastCol2　　 As Long　　'４新規シートの最終列数格納
　Dim DefSheetname As Variant '５初期のシート名取得
　Dim i　　　　　　As Long
　Dim j　　　　　　As Long
　Dim k　　　　　　As Long

　'初期シート名を取得。
　DefSheetname = ActiveSheet.Name
　'初期シートの最終列数取得。
　LastCol1 = Worksheets(DefSheetname).Range("A1").End(xlToRight).Column
　'シート名：レポートの新規シート追加。
　Worksheets.Add.Name = "レポート"
　'初期シートを選択。
　Worksheets(DefSheetname).Select
　'項目名希望順配列格納。
　myArray = Array("得意先C", "取引先名1", "製番", "相手管理NO", _
　　　　　　　　　"品目C", "製品名1", "受注数", "受注残数", _
　　　　　　　　　"納期", "受注単価", "受注金額", "出荷数", _
　　　　　　　　　"出荷金額", "出荷先名1", "郵便番号", "住所1", _
　　　　　　　　　"TEL", "FAX")
　k = 1
　'配列要素数分繰り返し処理。
　For i = LBound(myArray) To UBound(myArray)
　　'検索用の配列(項目名)格納。
　　strArray = myArray(i)
　　j = 0
　　With Worksheets(DefSheetname)
　　　On Error Resume Next
　　　'A1:LastCol1範囲で配列(項目名)検索し、番号で返す。
　　　j = WorksheetFunction.Match(strArray, .Range(.Cells(1, 1), .Cells(1, LastCol1)), 0)
　　　On Error GoTo 0
　　　If j > 0 Then
　　　　'シート名：レポートに変数jの列数目の値を入力。
　　　　.Columns(j).Copy Worksheets("レポート").Cells(k)
　　　　k = k + 1
　　　End If
　　End With
　Next i
End Sub

..こんな感じです。見比べてください。

でもちょっと効率悪そうですので
myArrayの項目名が元データに【必ずある】事が保障される場合は[フィルタオプション]が使えます。

Sub test1()
　Dim myArray As Variant
　Dim r　　　 As Range

　On Error GoTo extLine
　myArray = VBA.Array("得意先C", "取引先名1", "製番", "相手管理NO", _
　　　　　　　　　　　"品目C", "製品名1", "受注数", "受注残数", _
　　　　　　　　　　　"納期", "受注単価", "受注金額", "出荷数", _
　　　　　　　　　　　"出荷金額", "出荷先名1", "郵便番号", "住所1", _
　　　　　　　　　　　"TEL", "FAX")
　Set r = ActiveSheet.UsedRange
　With Worksheets.Add
　　.Name = "レポート"
　　With .Range("A1").Resize(, UBound(myArray) + 1)
　　　.Value = myArray
　　　r.AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　 CopyToRange:=.Cells, _
　　　　　　　　　　　 Unique:=False
　　End With
　End With

extLine:
　Set r = Nothing
　If Err.Number <> 0 Then MsgBox Err.Number & "::" & Err.Description
End Sub

補足

返信遅くなりすみません。
3種類もサンプルありがとうございました。

>・・・【必ずある】事が保障される場合・・・
配列の項目があるかどうかを判別してから処理するべきですね＾＾；
一番最初に記入していただいたサンプルを元に、判別処理など一部追記して使える様になりました。

最後に記入していただいたサンプルは、まだ理解できない部分が多いので勉強の参考にします。
ありがとうございました。

この後、ＶＢＡで別の質問をするのでよろしければ、また力を貸して下さい。
よろしくお願いします。

回答No.3

minaraiexcel

おかしいところがいくつかありますのでご指摘させていただきます。

シート名：レポートの新規シート追加してますよね？
Worksheets.Add.Name = "レポート"

なのに・・シート名：レポートの最終列数取得してますよね？
下記コードは一番右の列を見に行っている為、新規時点で256行となるはず。
LastCol2 = Worksheets("レポート").Range("A1").End(xlToRight).Column
↓
LastCol2 = Worksheets("レポート").cells(1,256).End(xlToLeft).Column

またコピー、貼り付けのコードもおかしいです。
コピーのときは一行をコピーしてますが、貼り付け時は範囲指定がおかしい・・
あと、『LastCol2』は変数なのに””でくくってしまったら文字列として判断してしまいますよ。

シート名：レポートに変数jの列数目の値を入力。
Columns(j).Copy

Range(Cells(1, 1), Cells(1, "LastCol2")).Past
↓
Columns(LastCol2).paste

補足

返信遅くなりすみません。
ご指摘ありがとうございました。

あやふやなところが多い為、参考になりました。
また質問をするつもりなので、よろしければまた力を貸して下さい。
よろしくお願いします。

回答No.2

end-u

もしくは、丸ごとコピーして順番をセットし、列単位で並べ替えたあとに不要な列を削除したほうが良さそうです。

Sub test2()
　　Dim myArray As Variant
　　Dim r　　　 As Range
　　Dim tmp　　 As Range

　　On Error GoTo extLine
　　myArray = Array("得意先C", "取引先名1", "製番", "相手管理NO", _
　　　　　　　　　　"品目C", "製品名1", "受注数", "受注残数", _
　　　　　　　　　　"納期", "受注単価", "受注金額", "出荷数", _
　　　　　　　　　　"出荷金額", "出荷先名1", "郵便番号", "住所1", _
　　　　　　　　　　"TEL", "FAX")
　　Set r = ActiveSheet.UsedRange
　　With Worksheets.Add
　　　　.Name = "レポート"
　　　　r.Copy .Range("A2")
　　　　Set r = .Range("A2").CurrentRegion.Rows(1).Offset(-1)
　　　　r.Value = Application.Match(r.Offset(1), myArray, 0)
　　　　r.CurrentRegion.Sort Key1:=.Range("A1"), _
　　　　　　　　　　　　　　 Order1:=xlAscending, _
　　　　　　　　　　　　　　 Header:=xlNo, _
　　　　　　　　　　　　　　 OrderCustom:=1, _
　　　　　　　　　　　　　　 MatchCase:=False, _
　　　　　　　　　　　　　　 Orientation:=xlLeftToRight, _
　　　　　　　　　　　　　　 SortMethod:=xlStroke
　　　　On Error Resume Next
　　　　Set tmp = r.SpecialCells(xlCellTypeConstants, xlErrors)
　　　　On Error GoTo 0
　　　　If Not tmp Is Nothing Then
　　　　　　tmp.EntireColumn.Delete
　　　　End If
　　　　.Rows(1).Delete
　　End With
extLine:
　　Set tmp = Nothing
　　Set r = Nothing
　　If Err.Number <> 0 Then MsgBox Err.Number & "::" & Err.Description
End Sub