Excel VBA質問箱 IV

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

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


54916 / 76732 ←次へ | 前へ→

【26599】複数列の比較がどうのこうのという質問でした
回答  りん E-MAIL  - 05/7/11(月) 21:21 -

引用なし
パスワード
   こんばんわ。
金曜日に上がっていた親記事が消えてしまっているので。
かなりあせっていたようなので、もう見に来ていないかもしれませんが。
品種    コード 数量 格納場所
 0 202536848  50   50
 0 202536848  50   50
 0 202536775 100   50
 0 202538225  50   50
 4 202535662  80  50305
 9 202538635 120  30301
 0 202538633  20  30310
こんなデータでした。

予定があり実績がないものがあり、予定が無いのに実績があるものがなく、順番に並んでいるとして。

Sub TEST()
  Dim ws As Worksheet, r1 As Range, Rmax As Long
  Dim RR As Long, CC As Long, tf As Boolean
  '作業用シート
  Set ws = Application.Workbooks.Add.Worksheets(1)
  ws.DisplayPageBreaks = False '少しでも処理が早くなるおまじない
  '
  With ThisWorkbook.Worksheets("Sheet1")
   Rmax = .Cells(.Rows.Count, 1).End(xlUp).Row 'A列最下行
   Set r1 = .Range(.Cells(2, 1), .Cells(Rmax, 4)) '2行目から
   r1.Copy Destination:=ws.Range("A1")
  End With
  '
  With ThisWorkbook.Worksheets("Sheet2")
   Rmax = .Cells(.Rows.Count, 1).End(xlUp).Row 'A列最下行
   Set r1 = .Range(.Cells(1, 1), .Cells(Rmax, 5))
   r1.Copy Destination:=ws.Range("G1")
  End With
  '見やすいように
  ws.Columns.AutoFit
  '予定と対応するように実績の位置をずらす
  With ws
   RR = 1
   Do
     If .Cells(RR, 8).Value = "" Then Exit Do
     RR = RR + 1
     If .Cells(RR, 2).Value <> .Cells(RR, 8).Value Then 'BとHで比較
      .Range(.Cells(RR, 7), .Cells(RR, 11)).Insert shift:=xlShiftDown
      .Cells(RR, 8).Value = .Cells(RR, 2).Value
      .Cells(RR, 9).Value = 0
      .Cells(RR, 10).Value = .Cells(RR, 4).Value
     End If
   Loop
   '
   Rmax = RR - 1 '最下行
   For RR = Rmax To 1 Step -1
     MsgBox RR
     tf = True
     For CC = 1 To 3
      tf = tf And (.Cells(RR, CC).Value = .Cells(RR, CC + 6).Value)
     Next
     '
     If tf = True Then
      .Rows(RR).Delete '一致したら削除
     Else
      If .Cells(RR, 1).Value <> .Cells(RR, 7).Value Then .Cells(RR, 1).Value = "-"
      .Range(.Cells(RR, 4), .Cells(RR, 6)).Value = _
      .Range(.Cells(RR, 9), .Cells(RR, 11)).Value
     End If
   Next
   Rmax = .Cells(.Rows.Count, 1).End(xlUp).Row 'A列最下行
   Set r1 = .Range(.Cells(1, 1), .Cells(Rmax, 6))
   '結果をSheet3に貼り付ける
   r1.Copy Destination:=ThisWorkbook.Worksheets("Sheet3").Range("A2")
  End With
  '作業用ブック破棄
  With ws.Parent
   .Saved = True
   .Close
  End With
  Set r1 = Nothing: Set ws = Nothing
End Sub
0 hits

【26599】複数列の比較がどうのこうのという質問でした りん 05/7/11(月) 21:21 回答
【26600】Re:複数列の比較がどうのこうのという質問... かみちゃん 05/7/11(月) 21:26 発言
【26602】Re:複数列の比較がどうのこうのという質問... りん 05/7/11(月) 21:35 発言

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