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

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

投稿日時 - 2010-09-11 22:23:46