Excel VBA質問箱 IV

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

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


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

【45634】データの転記について SoundPower 07/1/7(日) 22:00 質問[未読]
【45642】Re:データの転記について りん 07/1/8(月) 14:15 発言[未読]
【45651】Re:データの転記について SoundPower 07/1/8(月) 19:10 回答[未読]
【45662】Re:データの転記について りん 07/1/9(火) 14:05 回答[未読]
【45689】Re:データの転記について SoundPower 07/1/10(水) 22:28 お礼[未読]

【45634】データの転記について
質問  SoundPower  - 07/1/7(日) 22:00 -

引用なし
パスワード
    A B C D E F (結果)
1 0     100   選択
2 1     100   選択
3 2      20
4       80   選択
5 3      50   選択
6       40
7       10
8 0     100   選択
9 2     100   選択  ←[0]と[2]の間に[1]を行挿入

上の様なデータの整理マクロは可能でしょうか?
[詳細]
A列は基本的に0,1,2,3,0,1,2,3とデータが入ります。
連続して入っていない時はE列が100未満の為で、E列の合計が100に
なり次第、A列の数字は1上がる関係があります。
但し、抜ける場合があります。
 例:0,1,2,3,0,1,2,0,1,2,・・・
抜けた場合は抜けた数字を補完したいです。
 例:0,1,2,3,0,1,2,3,0,1,2,3・・・
   A列を補完した場合はE列にはゼロを入力
E列は0から100の数字が入ります。
選択したい行は一番大きい数値のある行です。
(50と50のように同じ数値のときは上の行を選ぶとします)
マクロ実施後は次のようになるのが理想です。
(別シートに出力願います)
 A B C D E F
1 0     100
2 1     100
3       80
4 3      50
5 0     100
6 1      0
7 2     100
    ↑B,C,Dのデータもあわせて転記したいです。

追伸:E列の合計100というのは小数点の丸め上、99.99から100.01くらい
の間でばらつく可能性があるります。

よろしくお願いします。

【45642】Re:データの転記について
発言  りん E-MAIL  - 07/1/8(月) 14:15 -

引用なし
パスワード
   SoundPower さん、こんにちわ。

> 例:0,1,2,3,0,1,2,0,1,2,・・・
>抜けた場合は抜けた数字を補完したいです。
> 例:0,1,2,3,0,1,2,3,0,1,2,3・・・
行挿入の方はそんなに難しくないのでおいておくとして、

> A B C D E F (結果)
>1 0     100   選択
>2 1     100   選択
>3 2      20
>4       80   選択
>5 3      50   選択
>6       40
>7       10
>8 0     100   選択
>9 2     100   選択  ←[0]と[2]の間に[1]を行挿入
選択される条件がはっきりしないと、回答は付きにくいと思います。

>E列は0から100の数字が入ります。
>選択したい行は一番大きい数値のある行です。
何について、どの範囲に対して、一番ですか?

【45651】Re:データの転記について
回答  SoundPower  - 07/1/8(月) 19:10 -

引用なし
パスワード
   りん さん 失礼しました。
>選択される条件がはっきりしないと、回答は付きにくいと思います。
>
>>E列は0から100の数字が入ります。
>>選択したい行は一番大きい数値のある行です。
>何について、どの範囲に対して、一番ですか?

A列の数字がデータのセットを表し、1セットの合計が約100なのです。
よって1個しかない(自動的に100)場合はいいのですが、複数ある
場合、例えば、
A   E
3  20
   40
   15
 +) 25
  100
3というセットの中でE列で最大なのは上から2番目の40というわけです。
この時、A列は空欄ですがA列からE列までの範囲のデータを抽出したいのです。

言葉が足りなくてすみませんでした。

【45662】Re:データの転記について
回答  りん E-MAIL  - 07/1/9(火) 14:05 -

引用なし
パスワード
   SoundPower さん、こんにちわ。

>A列の数字がデータのセットを表し、1セットの合計が約100なのです。
>よって1個しかない(自動的に100)場合はいいのですが、複数ある
>場合、例えば、
>A   E
>3  20
>   40
>   15
> +) 25
>  100
>3というセットの中でE列で最大なのは上から2番目の40というわけです。
>この時、A列は空欄ですがA列からE列までの範囲のデータを抽出したいのです。
データが連続しているところがEndキー+↑、Endキー+↓で判定できるものとして。

A列に数字のはいっていないところがセットの1つと考えて、
・新しいシートにコピー
・各セット毎の最大値抽出(最大値でないものを抽出して削除)
・A列の数字が0〜3を繰り返しているかどうかを判定して抜けてたら挿入

Sub TEST()
  Dim ws1 As Worksheet, ws2 As Worksheet, r1 As Range, r2 As Range
  Dim Rmax As Long, RR As Long, NN As Integer
  Dim Rp1 As Long, Rp2 As Long, Rp3 As Long, Rp4 As Long, Mdat As Double
  '
  Set ws1 = Application.ActiveSheet         '転記先
  Set ws2 = Application.Workbooks.Add.Worksheets(1) '転記元
  'コピー元範囲
  With ws1
   Rmax = .Range("E65536").End(xlUp).Row
   Set r1 = .Range(.Cells(1, 1), .Cells(Rmax, 5))
  End With
  r1.Copy
  'コピー先(念のため値のみ転記)
  ws2.Cells(1, 1).PasteSpecial Paste:=xlValues
  Application.CutCopyMode = False
  'A列が空白のところは、チェック対象
  With ws2
   Set r2 = .Cells(Rmax + 1, 1) '削除しても影響のないセル
   '
   Do
     RR = .Cells(Rmax, 1).End(xlUp).Row
     If RR = 1 Then Exit Do '一番上まで連続になったらループを抜ける
     '合計する範囲
     Rp2 = RR - 1 '一番下の行
     Rp1 = .Cells(RR, 1).End(xlUp).Row '一番上の行
     '一番上の値が暫定の最大値
     Rp4 = Rp1
     Mdat = .Cells(Rp4, 5).Value
     '最大値のチェック、最大値でないセルは削除用変数r2にセット
     For Rp3 = Rp1 + 1 To Rp2
      .Cells(Rp3, 1).Value = .Cells(Rp1, 1).Value
      If .Cells(Rp3, 5).Value > Mdat Then
        Mdat = .Cells(Rp3, 5).Value
        Set r2 = Application.Union(r2, .Cells(Rp4, 1)) '元の最大値セル
        Rp4 = Rp3 '行番号
      Else
        Set r2 = Application.Union(r2, .Cells(Rp3, 1)) '小さかった
      End If
     Next
   Loop
  End With
  r2.EntireRow.Delete 'まとめて行全体削除
  Set r2 = Nothing
  '最下行を再チェック
  With ws2
   Rmax = .Range("E65536").End(xlUp).Row
   Rp1 = 2
   Do
     For RR = Rp1 To Rmax
      NN = .Cells(RR, 1).Value - .Cells(RR - 1, 1).Value
      Select Case NN
        Case -3, 1
        Case Else
         '行挿入
         .Cells(RR, 1).EntireRow.Insert
         .Cells(RR, 1).Value = (.Cells(RR - 1, 1).Value + 1) Mod 4
         .Cells(RR, 5).Value = 0
         Rp1 = RR + 1 '次のチェックは挿入行のひとつ下から
         Rmax = Rmax + 1 '1行挿入したので最大値を+1
         Exit For
      End Select
      NN = -9 'ループを中断したか、最後までまわしたかの判定用
     Next
   Loop Until NN = -9 '最後まで無事にまわると抜ける
  End With
  '
  Set ws2 = Nothing: Set ws1 = Nothing
End Sub

とりあえず、こんな感じです。

【45689】Re:データの転記について
お礼  SoundPower  - 07/1/10(水) 22:28 -

引用なし
パスワード
   大変長いコード(お手間をかけさせ)ありがとうございます。
要望がかなえられました。

データ量は1回につき4Gくらいなのですが、速度もはやいです。

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