[[20170515153216]]　『VBA,キーをもとに別エクセルを参照したソート方法』（ななみ）　ページの最後に飛ぶ

『VBA,キーをもとに別エクセルを参照したソート方法』（ななみ）

 以下のように実現するVBAを作成したいです。 
 おしえていただけると助かります。

■条件
・Excel?@のソートコードを参照して、Excel?Aの表を昇順に並べ替える

・Excel?@のsheet("aaa")
　　 |　　A　　　 B
　　　　

 1行 |　 くだもの   　 ソートコード
 2行 |　 イチゴ　　　　　1     　　
 3行 | 　バナナ  　      2　
 4行 |　 メロン 　 　    3 　　
 5行 |   スイカ　        4   　　 
 6行 |   オレンジ        5

・Excel?Aのsheet("bbb")

　　 |　　A　　　 B

 1行 |　 値段   　くだもの
 2行 |　 120       メロン
 3行 |　 100　 　　オレンジ    　　　
 4行 |　 50 　   　バナナ  　　  　　 　　
 5行 | 　320 　 　 イチゴ
 6行 | 　500 　 　 スイカ

　　　　　　↓

・Excel?Aのsheet("bbb")(マクロ実行後）

　　 |　　A　　　 B
　　　　

 1行 |　 値段　　くだもの   　 
 2行 |　 320      イチゴ　　　　　     　　
 3行 | 　50       バナナ  　      　
 4行 |　 120       メロン 　 　    　　
 5行 |   500       スイカ　         　　 
 6行 |   100      オレンジ

お願いします。

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

Sub main()
'当ファイルに Sheets("bbb")があるとする
'当ファイルと同一フォルダ内の「a.xlsx」にSheets("aaa")があるとする

    Application.ScreenUpdating = False
    With ThisWorkbook.Sheets("bbb")
        .Columns("C:C").Insert Shift:=xlToRight
        .Columns("C:C").Insert Shift:=xlToRight
        .Columns("C:C").Insert Shift:=xlToRight
        Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\a.xlsx", ReadOnly:=True)
        .Columns("D:E").Value = wb.Sheets("aaa").Columns("A:B").Value
        wb.Close False
        For Each c In .UsedRange.Columns("C")
            c.FormulaR1C1 = "=INDEX(C[-2],MATCH(RC[1],C[-1],0))"
        Next c
        .Columns("C:C").Value = .Columns("C:C").Value
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("E2:E" & Rows.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange .Columns("C:E")
        .Sort.Header = xlYes
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
       .Range("A:B,E:E").Delete Shift:=xlToLeft
    End With
    Application.ScreenUpdating = False
End Sub
（mm） 2017/05/15(月) 17:41

mmさん

ありがとうございます。

質問なのですが、
.Columns("C:C").Insert Shift:=xlToRight
を三つ連続させる必要があるのはなぜでしょうか。

書いていただいたコードの概要を教えていただけると助かります。

よろしくお願いします。
（ななみ） 2017/05/15(月) 23:54

ところで、ご希望通りに稼動したのでしょうか？
（mm） 2017/05/16(火) 10:45

Sub 別案()
'作業列不使用
'ソートコードは1番から1づつ増加すること

    Dim dt(), wb As Workbook, c As Range, i As Long
    Set wb = Workbooks.Open(Filename:=ThisWorkbook.Path & "\a.xlsx", ReadOnly:=True)
    m = Application.WorksheetFunction.Max(wb.Sheets("aaa").Range("B:B"))
    ReDim dt(1, m)
    For Each c In wb.Sheets("aaa").Columns("B").SpecialCells(xlCellTypeConstants)
        dt(1, Val(c.Value)) = c.Offset(, -1).Value
    Next c
    wb.Close False
    For i = 0 To UBound(dt, 2)
        If Not dt(1, i) = Empty Then
        dt(0, i) = WorksheetFunction.Index(ThisWorkbook.Sheets("bbb").Range("A:A"), WorksheetFunction.Match(dt(1, i), ThisWorkbook.Sheets("bbb").Range("B:B"), 0))
        End If
    Next i
    For i = 0 To UBound(dt, 2)
        ThisWorkbook.Sheets("bbb").Range("A" & i + 1).Resize(UBound(dt, 1), 2).Value = Array(dt(0, i), dt(1, i))
    Next i
End Sub
（mm） 2017/05/16(火) 13:39

こんなのではどうですか。

 １）A列に作業列挿入
 ２）挿入した列にこんなイメージの式を入力
 　=vlookup(C1,ソートコードの表, 2,0)
 ３）A列の計算結果（ソートコード）で並べ替え
 ４）A列を削除

 Option Explicit

 Sub test()
    Dim フォルダ As String, ブック As String, シート As String
    Dim コード表 As String
    Dim 数式 As String

    フォルダ = ThisWorkbook.Path & "\"
    ブック = "コードリスト.xlsx"
    シート = "aaa"

    コード表 = "'" & フォルダ & "[" & ブック & "]" & シート & "'!A:B"
    数式 = "=VLOOKUP(C1," & コード表 & ",2,0)"

    Columns("A").Insert		'★１

    With Range("A1").CurrentRegion
        .Columns("A").Formula = 数式		'★２
        .Sort key1:=Columns("A"), order1:=xlAscending, Header:=xlYes	'★３
        .Columns("A").Delete		'★４
    End With

 End Sub

（マナ） 2017/05/16(火) 18:43

コメント返信：

[ 一覧(最新更新順) ]

[[20170515153216]] 『VBA,キーをもとに別エクセルを参照したソート方法』（ななみ） ページの最後に飛ぶ

[[20170515153216]]　『VBA,キーをもとに別エクセルを参照したソート方法』（ななみ）　ページの最後に飛ぶ