| |
こんばんわ。
金曜日に上がっていた親記事が消えてしまっているので。
かなりあせっていたようなので、もう見に来ていないかもしれませんが。
品種 ｺｰﾄﾞ 数量 格納場所
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 'Ａ列最下行
Set r1 = .Range(.Cells(2, 1), .Cells(Rmax, 4)) '２行目から
r1.Copy Destination:=ws.Range("A1")
End With
'
With ThisWorkbook.Worksheets("Sheet2")
Rmax = .Cells(.Rows.Count, 1).End(xlUp).Row 'Ａ列最下行
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 'Ａ列最下行
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 05/7/11(月) 21:21 -
