エクセル２０１０で表の複数の並び替え

2015/01/09 22:19

このQ&Aのポイント

エクセル２０１０の機能を使って、表のデータを複数の条件で並び替える方法を教えてください。
エクセル２０１０で表の複数の並び替えができる方法を詳しく教えてください。
エクセル２０１０を使って、表のデータを複数の要素で並び替える方法を知りたいです。

kuruna
お礼率81% (40/49)

その他（ビジネス・キャリア）
回答数1
ありがとう数1

みんなの回答 （1）
専門家の回答

質問者が選んだベストアンサー

ベストアンサー

tom04
ベストアンサー率49% (2537/5117)

2015/01/11 13:20 回答No.1

こんにちは！ VBAになりますが、一例です。元データはSheet1（↓の画像の左側）にあり、右側のSheet2に表示するとします。 Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに ↓のコードをコピー＆ペースト　→　Excel画面に戻り（VBE画面を閉じて）マクロを実行してみてください。（Alt＋F8キー　→　マクロ　→　マクロ実行です） Sub Sample1() 'この行から Dim i As Long, k As Long, lastRow1 As Long, lastRow3 As Long, myRow As Long, lastCol As Long Dim str As String, c As Range, r As Range, wS2 As Worksheet, wS3 As Worksheet Set wS2 = Worksheets("Sheet2") Application.ScreenUpdating = False wS2.Cells.Clear Worksheets.Add after:=Worksheets(Worksheets.Count) Set wS3 = Worksheets(Worksheets.Count) With Worksheets("Sheet1") lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row wS2.Range("B1") = .Range("A1") wS2.Range("C1") = .Range("C1") .Range("A:A").Insert .Range("A1") = "ダミー" For i = 1 To lastRow1 If Not IsNumeric(.Cells(i, "E")) Then str = .Cells(i, "E") Else .Cells(i, "A") = str End If Next i .Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("A1"), unique:=True .Range("D:D").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS3.Range("B1"), unique:=True wS3.Range("B1") = "ダミー" wS3.Range("B:B").Replace what:="商品", replacement:="", lookat:=xlWhole wS3.Range("A:B").SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp lastRow3 = wS3.Cells(Rows.Count, "A").End(xlUp).Row Range(wS3.Cells(2, "A"), wS3.Cells(lastRow3, "A")).Copy wS2.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True lastCol = wS2.Cells(1, Columns.Count).End(xlToLeft).Column + 1 wS2.Cells(1, lastCol) = .Range("C1") For i = 2 To wS3.Cells(Rows.Count, "B").End(xlUp).Row .Range("A1").AutoFilter field:=4, Criteria1:=wS3.Cells(i, "B") If .Cells(Rows.Count, "A").End(xlUp).Row > 1 Then Range(.Cells(2, "A"), .Cells(lastRow1, "E")).SpecialCells(xlCellTypeVisible).Copy _ wS3.Range("C1") For k = 1 To wS3.Cells(Rows.Count, "C").End(xlUp).Row Set c = wS2.Range("A:A").Find(what:=wS3.Cells(k, "C") & wS3.Cells(k, "D") & _ wS3.Cells(k, "E") & wS3.Cells(k, "F"), LookIn:=xlValues, lookat:=xlWhole) If c Is Nothing Then myRow = wS2.UsedRange.Rows.Count + 1 wS2.Cells(myRow, "A") = wS3.Cells(k, "C") & wS3.Cells(k, "D") & wS3.Cells(k, "E") & wS3.Cells(k, "F") Else myRow = c.Row End If Set r = wS2.Rows(1).Find(what:=wS3.Cells(k, "C"), LookIn:=xlValues, lookat:=xlWhole) wS2.Cells(myRow, "B") = wS3.Cells(k, "D") wS2.Cells(myRow, "C") = wS3.Cells(k, "F") wS2.Cells(myRow, r.Column) = wS3.Cells(k, "G") wS2.Cells(myRow, lastCol) = wS3.Cells(k, "E") Next k wS3.Range("C:G").Clear End If Next i .AutoFilterMode = False .Range("A:A").Delete wS2.Range("A:A").Delete Application.DisplayAlerts = False wS3.Delete Application.ScreenUpdating = True wS2.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous wS2.Columns.AutoFit wS2.Activate wS2.Range("A1").Select For i = wS2.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1 If wS2.Cells(i, "B") = wS2.Cells(i - 1, "B") Then wS2.Cells(i, "B").ClearContents End If Next i End With Application.ScreenUpdating = True End Sub 'この行まで ※　関数でないので、データ変更があるたびにマクロを実行する必要があります。m(_ _)m