Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

54797 / 76732

←次へ　｜　前へ→


	【26721】Re:重複データを整理したい

ichinose - 05/7/15(金) 7:22 -


	引用なし

	パスワード

▼YN さん：
おはようございます。
>WindowsとOfficeのバージョン
>EXCEL2000（Win98）です。
>
>サンプルは全く同じものを使っております。
>多分変数の設定で引っかかっているように感じます。

同じWin98&Excel2000で確認しましたが、未だ再現出来ません。
ひょっとして、
コード記述モジュールに

Option Explicit

これを宣言していますか？
そうだたしたら、削除してください。
でもこれだとしてもエラーがご提示されたものとは違いますが・・・。

>変数の抜けているものがありましたら、明示していただけませんでしょうか。
一応、変数を宣言したコードです。

'==============================================================
Option Explicit
'==============================================================
Sub main()
　　Dim rng As Range
　　Dim rnga As Range
　　Dim rngb As Range
　　Dim tr As Range
　　Dim ctag As Range
　　Dim maxbnd As Long
　　Dim ad1 As String, ad2 As String
　　Dim sushiki As String
　　Dim ans As Variant
　　Dim idx 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) As Variant
　 Dim clct As New Collection
　 Dim ansrng As Range
　 Dim addvalue As Variant
　 Dim cnt As Long
　 Dim ans() As Variant
　 Dim cr As Range
　 Dim idx As Long
　 get_num_value = False
　 With rng
　　 .Formula = sushiki
　　 On Error Resume Next
　　 Set ansrng = .SpecialCells(xlCellTypeFormulas, xlNumbers)
　　 If Err.Number = 0 Then
　　　　Err.Clear
　　　　cnt = 0
　　　　For Each cr In ansrng
　　　　　 If cnt + 1 < ansrng.Count Then
　　　　　　　clct.Add cr.Value, Str(cr.Value)
　　　　　 Else
　　　　　　　addvalue = cr.Value
　　　　　　　End If
　　　　　 cnt = cnt + 1
　　　　　 Next
　　　　ReDim ans(1 To clct.Count + 1)
　　　　For idx = 1 To clct.Count
　　　　　 ans(idx) = clct.Item(idx)
　　　　　 Next
　　　　ans(clct.Count + 1) = addvalue
　　　　get_num_value = ans()
　　　　End If
　　 .ClearContents
　　 End With
　 Set clct = Nothing
End Function

1 hits

▼

【26550】重複データを整理したい k 05/7/8(金) 16:51