Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


19253 / 76732 ←次へ | 前へ→

【62914】Re:複数の条件で抽出したい
回答  Hirofumi  - 09/9/15(火) 18:00 -

引用なし
パスワード
   こんなのでは

ListはSheet1のA1から始まり、結果はSheet2に出力されます
Sheet1には、列見出しが有る物とします

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜C列)
  Const clngColumns As Long = 3
  '「コード」の有る列(A列のA列からの列Offset)
  Const clngGroup1 As Long = 1
  '「日付」の有る列(B列のA列からの列Offset)
  Const clngGroup2 As Long = 0
  
  Dim i As Long
  Dim lngRows As Long
  Dim lngTop As Long
  Dim lngWright As Long
  Dim rngList As Range
  Dim rngResult As Range
  Dim vntGroup As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  '結果出力の位置を設定
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row, clngGroup1).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データに連番を付与(最終列の後ろに)
    .Offset(, clngColumns).EntireColumn.Insert
    With .Offset(1, clngColumns)
      .Value = 1
      .Resize(lngRows).DataSeries _
          Rowcol:=xlColumns, Type:=xlLinear, _
          Date:=xlDay, Step:=1, Trend:=False
    End With
    'データを「コード」、「日付」列をKeyとして整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngGroup1), Order1:=xlAscending, _
        Key2:=.Offset(, clngGroup2), Order2:=xlDescending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '「コード」列データを配列に取得
    vntGroup = .Offset(1, clngGroup1).Resize(lngRows + 1).Value
  End With
  
  '注目値の位置を記録
  lngTop = 1
  '先頭データを出力
  For i = 2 To lngRows + 1
    '注目値と現在値が違った場合
    If vntGroup(lngTop, 1) <> vntGroup(i, 1) Then
      'データを転記
      lngWright = lngWright + 1
      rngList.Offset(lngTop).Resize(, clngColumns).Copy _
          Destination:=rngResult.Offset(lngWright)
      '注目値の位置を記録
      lngTop = i
    End If
  Next i

  'データ位置の復帰
  With rngList
    'データを「コード」、「日付」列をKeyとして整列
    .Offset(1).Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    '連番削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub
1 hits

【62912】複数の条件で抽出したい 秋刀魚 09/9/15(火) 16:50 質問
【62913】Re:複数の条件で抽出したい Jaka 09/9/15(火) 17:20 発言
【62914】Re:複数の条件で抽出したい Hirofumi 09/9/15(火) 18:00 回答
【62915】Re:複数の条件で抽出したい 秋刀魚 09/9/15(火) 21:50 お礼
【62920】Re:複数の条件で抽出したい kanabun 09/9/17(木) 12:07 発言
【62929】Re:複数の条件で抽出したい kanabun 09/9/18(金) 23:33 発言

19253 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free