| |
▼k さん、NYさん、おはようございます。
ちょっと変更したので再送です。
>>元のデータは
>1つの注番について複数の部番があります。
>部番それぞれについて日付を2つずつ持っています。
>部番は重複している場合もあるし、していない場合もあります。
>
>例えば
>注番 部番 日付A 日付B
>1 あ 2005/7/1 2005/7/2
>1 あ 2005/7/2 2005/7/3
>1 い 2005/7/1 2005/7/2
>2 あ 2005/7/3 2005/7/4
>2 う 2005/7/4 2005/7/5
>2 う 2005/7/5 2005/7/6
>2 う 2005/7/6 2005/7/7
元データである上記のシートをアクティブにして以下のコードを
実行してみてください。
尚、結果を作成するシートはSheet2と言う名前のシートに作成します。
Sheet2は予め準備しておいてください。
又、元データのあるシートのＥ，Ｆ列を作業列として使用しています。
'====================================================================
Sub main()
Dim rng As Range
Dim rnga As Range
Dim rngb As Range
Dim tr As Range
Dim maxbnd As Long
maxbnd = 0
Worksheets("sheet2").Cells.ClearContents
Set rnga = Range("a2", Cells(Rows.Count, 1).End(xlUp))
Set rng = Range("a1", Cells(Rows.Count, 1).End(xlUp))
If rng.Count >= 2 Then
rng.Resize(, 2).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("sheet2").Range("a1"), _
Unique:=True
With Worksheets("sheet2")
Set rngb = .Range("a2", .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each tr In rngb
ad1 = tr.Address(, , xlR1C1, True)
ad2 = tr.Offset(0, 1).Address(, , xlR1C1, True)
sushiki = "=IF(AND(rc1=" & ad1 & ",rc2=" & ad2 & "),IF(ISNUMBER(rc[-2]),rc[-2]))"
ans = get_num_value(rnga.Offset(0, 4).Resize(, 2), sushiki)
If VarType(ans) <> vbBoolean Then
If UBound(ans) > maxbnd Then maxbnd = UBound(ans)
With tr.Offset(0, 2).Resize(, UBound(ans))
.Value = ans
.NumberFormatLocal = "yyyy/m/d"
End With
End If
Next
If maxbnd > 0 Then
For Each ctag In Worksheets("sheet2").Range("c1", Worksheets("sheet2").Cells(1, maxbnd + 2))
ctag.Value = "日付" & idx + 1
idx = idx + 1
Next
End If
End If
End Sub
'==========================================================================
Function get_num_value(rng As Range, sushiki) As Variant
'指定されたセル範囲に指定された数式を代入し、結果が数値のセル範囲のみを重複なしの配列として返す
'数値データがない場合はFalse
Dim clct As New Collection
get_num_value = False
With rng
.Formula = sushiki
On Error Resume Next
Set ansrng = .SpecialCells(xlCellTypeFormulas, xlNumbers)
If Err.Number = 0 Then
Err.Clear
For Each cr In ansrng
clct.Add cr, Str(cr)
Next
ReDim ans(1 To clct.Count)
For idx = 1 To clct.Count
ans(idx) = clct.Item(idx)
Next
get_num_value = ans()
End If
.ClearContents
End With
End Function
|
|
ichinose
- 05/7/13(水) 6:11 -
