[[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

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

 1)A列に作業列挿入
 2)挿入した列にこんなイメージの式を入力
  =vlookup(C1,ソートコードの表, 2,0)
 3)A列の計算結果(ソートコード)で並べ替え
 4)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		'★1

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

 End Sub

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


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.