0

WinActorV4ユーザです。

Excel sheetを指定列でフィルターするコードは下記のようです。

このアウトプットにC列で降順に並び替えする機能を追加したいが、どのようにコードを追加すればよいでしょうか?

=<スクリプトここから>=====

' ファイルのパスをフルパスに変換する
Set fso = CreateObject("Scripting.FileSystemObject")
filePath = fso.GetAbsolutePathName(!ファイル名!)

' workbookオブジェクトを取得する
Set workbook = Nothing
On Error Resume Next
  ' 既存のエクセルが起動されていれば警告を抑制する
  Set existingXlsApp = Nothing
  Set existingXlsApp = GetObject(, "Excel.Application")
  existingXlsApp.DisplayAlerts = False

  ' 一先ずWorkbookオブジェクトをGetObjectしてみる
  Set workbook = GetObject(filePath)
  Set xlsApp = workbook.Parent

  ' GetObjectによって新規に開かれたWorkbookなら
  ' 変数にNothingを代入することで参照が0になるため
  ' 自動的に閉じられる。
  Set workbook = Nothing

  ' Workbookがまだ存在するか確認する
  For Each book In xlsApp.Workbooks
    If book.FullName = filePath Then
      ' Workbookがまだ存在するので、このWorkbookは既に開かれていたもの
      Set workbook = book
      xlsApp.Visible = True
    End If
  Next

  ' Workbookが存在しない場合は、新たに開く。
  If workbook Is Nothing Then
    Set xlsApp = Nothing

    ' Excelが既に開かれていたならそれを再利用する
    If Not existingXlsApp Is Nothing Then
      Set xlsApp = existingXlsApp
      xlsApp.Visible = True
    Else
      Set xlsApp = CreateObject("Excel.Application")
      xlsApp.Visible = True
    End If

    Set workbook = xlsApp.Workbooks.Open(filePath)
  End If

  ' 警告の抑制を元に戻す
  existingXlsApp.DisplayAlerts = True
  Set existingXlsApp = Nothing
On Error Goto 0

If workbook Is Nothing Then
  Err.Raise 1, "", "指定されたファイルを開くことができません。"
End If

' ====指定されたシートを取得する==================================================

sheetName = !シート名!
Set worksheet = Nothing
On Error Resume Next
  ' シート名が指定されていない場合は、アクティブシートを対象とする
  If sheetName = "" Then
    Set worksheet = workbook.ActiveSheet
  Else
    Set worksheet = workbook.Worksheets(sheetName)
  End If
On Error Goto 0

If worksheet Is Nothing Then
  Err.Raise 1, "", "指定されたシートが見つかりません。"
End If

' ====ハイライトを表示する========================================================

' HwndプロパティはExcel2002以降のみ対応
On Error Resume Next
  ShowUMSHighlight(xlsApp.Hwnd)
On Error Goto 0

' ==============================================================

cellAddress = !セル位置!
col = 0 + !列番号!
key = !絞込みキー!

Set cell = Nothing
On Error Resume Next
  ' R1C1形式にも対応する。
  Set objRE = CreateObject("VBScript.RegExp")
  objRE.IgnoreCase = True
  objRE.Pattern = "^R(\d+)C(\d+)$"
  Set matches = objRE.Execute(cellAddress)

  If matches.Count = 0 Then
    Set cell = worksheet.Range(cellAddress)
  Else
    Set cell = worksheet.Cells(matches(0).SubMatches(0) + 0, matches(0).SubMatches(1) + 0)
  End If
On Error Goto 0

If cell Is Nothing Then
  Err.Raise 1, "", "指定されたセルが見つかりません。"
End If

cell.select
xlsApp.Selection.AutoFilter col, key

Set objRe = Nothing
Set xlsApp = Nothing
Set worksheet = Nothing
Set workbook = Nothing
Set fso = Nothing

==<スクリプトここまで>==

gorby5775 質問の投稿
回答とコメントは、会員登録(無料)で閲覧できるようになります。