Excel VBA質問箱 IV

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

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


2975 / 13644 ツリー ←次へ | 前へ→

【64957】データの抜き出しソートについて ゆぅ 10/3/29(月) 23:28 質問[未読]
【64959】Re:データの抜き出しソートについて Hirofumi 10/3/30(火) 7:32 発言[未読]
【64960】Re:データの抜き出しソートについて teian 10/3/30(火) 8:50 回答[未読]
【64963】Re:データの抜き出しソートについて teian 10/3/30(火) 15:42 回答[未読]
【64969】Re:データの抜き出しソートについて ゆぅ 10/3/30(火) 23:21 お礼[未読]
【64970】Re:データの抜き出しソートについて teian 10/3/31(水) 12:22 回答[未読]
【64971】Re:データの抜き出しソートについて Hirofumi 10/3/31(水) 12:43 発言[未読]
【64981】Re:データの抜き出しソートについて teian 10/3/31(水) 15:43 回答[未読]
【64989】Re:データの抜き出しソートについて Hirofumi 10/3/31(水) 17:41 回答[未読]
【64990】Re:データの抜き出しソートについて teian 10/3/31(水) 17:51 発言[未読]
【64991】Re:データの抜き出しソートについて Hirofumi 10/3/31(水) 18:40 回答[未読]

【64957】データの抜き出しソートについて
質問  ゆぅ  - 10/3/29(月) 23:28 -

引用なし
パスワード
   はじめまして、お世話になります。
VBAを最近始めてデータの抜き出しについて悩んでます。

日付 項目 値段
3/14 ★  110
3/13 ★  115
3/12 ☆  108
3/11 ☆  100
3/10 ★  223
3/9  ★  242
3/8  ★  265

各セル↑となってるデータの項目が同じものが連続している(★★等)なら日付の新しい&値段の高い値でまとめたいのです。
こんな感じに↓

日付 項目 値段
3/14 ★  115
3/12 ☆  108
3/10 ★  265

For文使ってデータの数だけループ、下記のようなIF文判定して行消しと作ってみましたが行消すところが固まったように遅いのです。

xpos_check、ypos_check:1つ目のデータ位置
xpos_check2、ypos_check2:2つ目のデータ位置

If (Cells(xpos_check, ypos_check) = "★") And (Cells(xpos_check2, ypos_check2) = "★") Then

   Cells(xpos_check, ypos_check + 1).Value = Cells(xpos_check2, ypos_check2 + 1).Value
   Cells(xpos_check, ypos_check + 2).Value = Cells(xpos_check2, ypos_check2 + 2).Value
    
   Range(Cells(xpos_check2, ypos_DATE), Cells(xpos_check2, ypos_DATE)).Select
   Selection.Delete Shift:=xlUp

何かいい手はありますでしょうか?
ご教授お願いいたします。

【64959】Re:データの抜き出しソートについて
発言  Hirofumi  - 10/3/30(火) 7:32 -

引用なし
パスワード
   >各セル↑となってるデータの項目が同じものが連続している(★★等)なら
>日付の新しい&値段の高い値でまとめたいのです。
>こんな感じに↓
>
>日付 項目 値段
>3/14 ★  115
>3/12 ☆  108
>3/10 ★  265

一番肝心な抽出条件(削除条件)が曖昧だから上手く行かないのでは?

1、Listに手を加えない状態で(詰まり整列等を行わない
2、★印列の同じ値が連続しているしている行範囲

までは解るのですが
「日付の新しい&値段の高い値でまとめたいのです。」
が曖昧です
日付が新しい物が常に値段が高いなら善いのですが?
日付が新しい物でも値段が低い場合はどうするの?
この様な、条件をハッキリさせないから上手く行かないのでは?

条件がハッキリするなら
手法の1例として

1、項目列(★印列)を上から見て行く
2、項目列の値が変わったら
3、変わる前までの範囲の中で残す行(若しくは削除する行)に印をつけます
 例えば値段の後ろの列に、「*」等を入れます
4、最終行まで此れを繰り返し
5、値段の後ろの列をKeyとしてListを整列
6、「*」が上に集まるので、「*」が在る行を残して行削除

で出来るのでは?

【64960】Re:データの抜き出しソートについて
回答  teian  - 10/3/30(火) 8:50 -

引用なし
パスワード
   >各セル↑となってるデータの項目が同じものが連続している(★★等)なら日付の新しい&値段の高い値でまとめたいのです。
は、律儀にやるとすれば↓見たいな感じでしょうか。

  Dim oldRow As Long, oldKey As Variant
  Dim i As Long
  With Worksheets(1)
    oldRow = .Range("B" & .Rows.Count).End(xlUp).Row
    oldKey = .Range("B" & oldRow).Value
    For i = oldRow To 2 Step -1
      If .Range("B" & i).Value <> .Range("B" & i - 1).Value Then
        .Range("A" & i).Value = _
          WorksheetFunction.Max(.Range("A" & i & ":A" & oldRow))
        .Range("C" & i).Value = _
          WorksheetFunction.Max(.Range("C" & i & ":C" & oldRow))
        .Rows(i + 1 & ":" & oldRow).Delete xlShiftUp
        oldRow = i - 1
      End If
    Next
  End With

Sortをどこに登場させたらいいのかは知りません。

【64963】Re:データの抜き出しソートについて
回答  teian  - 10/3/30(火) 15:42 -

引用なし
パスワード
   朝出かける前で、あまり確認せずコードを提示したら大失敗。
ゴミあり、バグありのコードでした、失礼しました。
(必ず複数行ならいいのですが、纏めるものがなく1行のデータがあると
余計なものまで消しちまいました。)

訂正版をアップしておきます。

Dim oldRow As Long
Dim i As Long
With Worksheets(1)
  oldRow = .Range("B" & .Rows.Count).End(xlUp).Row
  For i = oldRow To 2 Step -1
    If .Range("B" & i).Value <> .Range("B" & i - 1).Value Then
      If oldRow > i Then
        .Range("A" & i).Value = _
          WorksheetFunction.Max(.Range("A" & i & ":A" & oldRow))
        .Range("C" & i).Value = _
          WorksheetFunction.Max(.Range("C" & i & ":C" & oldRow))
        .Rows(i + 1 & ":" & oldRow).Delete xlShiftUp
      End If
      oldRow = i - 1
    End If
  Next
End With

【64969】Re:データの抜き出しソートについて
お礼  ゆぅ  - 10/3/30(火) 23:21 -

引用なし
パスワード
   hirohumiさん、Teianさん回答ありがとうございます。
私が作った判定だと★が3個以上の時の判断がダメだったので
Teianさんのやり方がとても参考になりました。

やっぱり全行消し、の方が処理早いんでしょうか。
範囲選択で行消しだと止まったようになってしまうのです。
データがたくさんあるからかもしれませんが。
いろいろ試してみます(^^)

【64970】Re:データの抜き出しソートについて
回答  teian  - 10/3/31(水) 12:22 -

引用なし
パスワード
   ▼ゆぅ さん:
>やっぱり全行消し、の方が処理早いんでしょうか。
>範囲選択で行消しだと止まったようになってしまうのです。
>データがたくさんあるからかもしれませんが。
>いろいろ試してみます(^^)

効率にこだわるなら、行の削除とかの重い処理をしなくて済む方法はないかと考えますね。
それでもやはり行削除が必要ならいっぺんに行う方法を考えます。
以下は、メモリー上(配列)でデータを加工して、
一気に吐き出す考えにしたもので、行削除不要としたコード例です。
そのたくさんのデータのあるシートで前のコードと
比較してみるといいかもしれません。

Dim v As Variant, w As Variant
Dim i As Long, j As Long, k As Long
With Worksheets(1).Range("A1").CurrentRegion
'  v = .Value
  v = .Columns("A:C").Value
  ReDim w(1 To UBound(v, 1), 1 To UBound(v, 2))
  k = 1
  For j = 1 To UBound(v, 2)
    w(k, j) = v(k, j)
  Next
  For i = 2 To UBound(v)
    If v(i, 2) = w(k, 2) Then
      w(k, 1) = WorksheetFunction.Max(w(k, 1), v(i, 1))
      w(k, 3) = WorksheetFunction.Max(w(k, 3), v(i, 3))
    Else
      k = k + 1
      For j = 1 To UBound(v, 2)
        w(k, j) = v(i, j)
      Next
    End If
  Next
  .ClearContents
  .Resize(k, UBound(w, 2)).Value = w
End With

なお、データはA:C列にあり1行目はヘッダー行であるという前提にしたので、
安易にForループを2行目からにしてMax関数での例外を避けてますけど。

【64971】Re:データの抜き出しソートについて
発言  Hirofumi  - 10/3/31(水) 12:43 -

引用なし
パスワード
   行処理で、リソース優先で大きな配列を用意しなくても幾らか速く成る様です?

「日付」の列見出しがA1に在る物とします

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim lngRow As Long
  Dim lngRowEnd As Long
  Dim vntResult As Variant
  Dim vntData As Variant
  
  Application.ScreenUpdating = False
  
  With ActiveSheet
    '最終行を取得
    lngRowEnd = .Cells(Rows.Count, "A").End(xlUp).Row
    '書き込み行初期値(2行目から書き込む)
    lngRow = 2
    '出力用配列の初期値取得(2行目を3列読み込む)
    vntResult = .Range(.Cells(lngRow, "A"), .Cells(lngRow, "C")).Value
    'データ2行目から最終行+1まで繰り返し
    For i = lngRow + 1 To lngRowEnd + 1
      'Loopで見ている行、1行分配列に取得
      vntData = .Range(.Cells(i, "A"), .Cells(i, "C")).Value
      '前の行と項目列の値が同じなら
      If vntResult(1, 2) = vntData(1, 2) Then
        'もし、読み込んだ行の日付が出力用配列の日付より大きければ
        If vntResult(1, 1) < vntData(1, 1) Then
          '出力用配列の日付を入れ替える
          vntResult(1, 1) = vntData(1, 1)
        End If
        'もし、読み込んだ行の値段が出力用配列の値段より大きければ
        If vntResult(1, 3) < vntData(1, 3) Then
          '出力用配列の日付を入れ替える
          vntResult(1, 3) = vntData(1, 3)
        End If
      Else
        '出力用配列を書き込み位置に出力
        .Range(.Cells(lngRow, "A"), .Cells(lngRow, "C")).Value = vntResult
        '書き込み位置を更新
        lngRow = lngRow + 1
        '出力用配列の中身を読み込んだ行のデータに入れ替え
        vntResult = vntData
      End If
    Next i
    '余分なデータを削除
    .Range(.Cells(lngRow, "A"), .Cells(lngRowEnd, "C")).Delete
  End With
  
  Application.ScreenUpdating = True
  
  MsgBox "処理が完了しました", vbInformation

End Sub

【64981】Re:データの抜き出しソートについて
回答  teian  - 10/3/31(水) 15:43 -

引用なし
パスワード
   ▼Hirofumi さん:
>    '余分なデータを削除
>    .Range(.Cells(lngRow, "A"), .Cells(lngRowEnd, "C")).Delete
のように、無条件に削除だと、まったく集約されることがないデータ群だと
必要なデータも削除しませんか? 大丈夫ですか?
自分も同じようにそんな考慮漏れコードを提示したのでちょっと気になりました。
確認してみて下さい。

【64989】Re:データの抜き出しソートについて
回答  Hirofumi  - 10/3/31(水) 17:41 -

引用なし
パスワード
   >▼Hirofumi さん:
>>    '余分なデータを削除
>>    .Range(.Cells(lngRow, "A"), .Cells(lngRowEnd, "C")).Delete
>のように、無条件に削除だと、まったく集約されることがないデータ群だと
>必要なデータも削除しませんか? 大丈夫ですか?
>自分も同じようにそんな考慮漏れコードを提示したのでちょっと気になりました。
>確認してみて下さい。

この時点で、
抽出したデータは、2行目〜lngRow-1までの間に転記済なので
抽出済みのデータlngRow〜lngRowEndまでの行を削除していますが?
何か変ですか?

【64990】Re:データの抜き出しソートについて
発言  teian  - 10/3/31(水) 17:51 -

引用なし
パスワード
   ▼Hirofumi さん:
>この時点で、
>抽出したデータは、2行目〜lngRow-1までの間に転記済なので
>抽出済みのデータlngRow〜lngRowEndまでの行を削除していますが?
>何か変ですか?

ロジックをよく理解してませんが、
サンプルデータを一度処理した結果に対して、
もう一度この処理を動かすと、最後の行が消えていきませんか?ってことです。

私の早合点かな?

【64991】Re:データの抜き出しソートについて
回答  Hirofumi  - 10/3/31(水) 18:40 -

引用なし
パスワード
   ▼teian さん:
>▼Hirofumi さん:
>>この時点で、
>>抽出したデータは、2行目〜lngRow-1までの間に転記済なので
>>抽出済みのデータlngRow〜lngRowEndまでの行を削除していますが?
>>何か変ですか?
>
>ロジックをよく理解してませんが、
>サンプルデータを一度処理した結果に対して、
>もう一度この処理を動かすと、最後の行が消えていきませんか?ってことです。
>
>私の早合点かな?

あ!!!
ありがとうございます
2度動かす事を考えませんでした
以下の様に追加して下さい

    '余分なデータを削除
    If lngRow < lngRowEnd Then '★追加
      .Range(.Cells(lngRow, "A"), .Cells(lngRowEnd, "C")).Delete
    End If '★追加

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