Excel VBA質問箱 IV

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

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


9551 / 13646 ツリー ←次へ | 前へ→

【26550】重複データを整理したい k 05/7/8(金) 16:51 質問[未読]
【26551】Re:重複データを整理したい NY 05/7/8(金) 17:54 回答[未読]
【26622】Re:重複データを整理したい k 05/7/12(火) 11:01 質問[未読]
【26657】Re:重複データを整理したい ichinose 05/7/13(水) 6:11 発言[未読]
【26663】Re:重複データを整理したい k 05/7/13(水) 15:14 質問[未読]
【26673】Re:重複データを整理したい ichinose 05/7/13(水) 18:57 発言[未読]
【26674】Re:重複データを整理したい YN 05/7/13(水) 20:23 質問[未読]
【26681】Re:重複データを整理したい ichinose 05/7/14(木) 5:57 発言[未読]
【26683】Re:重複データを整理したい YN 05/7/14(木) 6:58 質問[未読]
【26721】Re:重複データを整理したい ichinose 05/7/15(金) 7:22 発言[未読]
【26748】Re:重複データを整理したい YN 05/7/15(金) 21:48 お礼[未読]
【26749】Re:重複データを整理したい ichinose 05/7/16(土) 0:13 発言[未読]
【26698】Re:重複データを整理したい k 05/7/14(木) 11:45 お礼[未読]

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

引用なし
パスワード
   みなさんこんにちは。
こちらに質問していいか迷ったのですが、どうしたらいいかさっぱり分からないので投稿してしまいました。
どなたか教えていただけますでしょうか。よろしくお願いいたします。

このようなデータがあります。
注番    部番    日付A      日付B
1    あ    yyyy/mm/dd  yyyy/mm/dd
1    あ    ・      ・
1    い    ・      ・
1    い    ・      ・
1    い    ・      ・
1    う    ・      ・
1    え    ・      ・
2    い    ・      ・
2    い    ・      ・
2    え    ・      ・
2    お    ・      ・
3    あ    ・      ・
3    う    ・      ・
・    ・    ・      ・
・    ・    ・      ・
・    ・    ・      ・

これはこのような意味です。
注番    部番    日付1    日付2    日付3    日付4    日付5
1    あ    A    B            
1    あ        A    B        
1    い    A    B            
1    い        A    B        
1    い            A    B    
・    ・    ・    ・            
・    ・    ・    ・            
・    ・    ・    ・            

これをこのようにまとめたいのです。
注番    部番    日付1    日付2    日付3    日付4    日付5
1    あ    A    B    B        
1    い    A    B    B    B    
・    ・    ・    ・
・    ・    ・    ・
・    ・    ・    ・

どうぞよろしくお願いいたします。

【26551】Re:重複データを整理したい
回答  NY  - 05/7/8(金) 17:54 -

引用なし
パスワード
   ▼k さん:
こんにちは

部番を基準に考えて重複データを整理させるのでしょうか。
そのように理解しますと、

Dim コピー位置 As Range
Set コピー位置 = Range("A65536").End(xlUp).Offset(2)
ActiveCell.CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
copytorange:=Range("B65536").End(xlUp).Offset(3), _
unique:=True

これで2行下にデータが整理されると思います。

【26622】Re:重複データを整理したい
質問  k  - 05/7/12(火) 11:01 -

引用なし
パスワード
   NYさん、どうもありがとうございました。
実行してみましたが、同じ内容がそっくり2行下にコピーされてしまいました。
(やり方が悪いのかもしれないのですが・・・)

ちょっと説明がよくなかったようなので、補足させていただきます。

元のデータは
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


これを
注番 部番  日付1  日付2   日付3   日付4
1   あ  2005/7/1 2005/7/2 2005/7/3
1   い  2005/7/2 2005/7/3
2   あ  2005/7/3 2005/7/4
2   う  2005/7/4 2005/7/5 2005/7/6 2005/7/7

といったように整理したいのです。
説明が下手ですみません。
どうぞよろしくお願いいたします。

【26657】Re:重複データを整理したい
発言  ichinose  - 05/7/13(水) 6:11 -

引用なし
パスワード
   ▼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は予め準備しておいてください。

又、元データのあるシートのE,F列を作業列として使用しています。

'====================================================================
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

【26663】Re:重複データを整理したい
質問  k  - 05/7/13(水) 15:14 -

引用なし
パスワード
   ichinoseさん、どうもありがとうございます!
うまく整理することができました。

ただ、下のような結果になったものがあります。

元データ
注番 部番  日付A      日付B
1   あ   2005/7/6   2005/7/1
1   あ   2005/7/1    2005/6/30
1   あ   2005/6/30    2005/6/27
1   あ   2005/6/27    2005/6/30


実行結果
注番  部番  日付1   日付2   日付3    日付4    日付5
1   あ  2005/7/6  2005/7/1  2005/6/30  2005/6/27    


日付5に"2005/6/30"と入るはずなのですが、入りません。
前の日付とダブっているからなのでしょうか。。。
申し訳ありませんが、教えていただけますか。

【26673】Re:重複データを整理したい
発言  ichinose  - 05/7/13(水) 18:57 -

引用なし
パスワード
   ▼k さん:
こんばんは。

>ichinoseさん、どうもありがとうございます!
>うまく整理することができました。
>
>ただ、下のような結果になったものがあります。
>
>元データ
>注番 部番  日付A      日付B
>1   あ   2005/7/6   2005/7/1
>1   あ   2005/7/1    2005/6/30
>1   あ   2005/6/30    2005/6/27
>1   あ   2005/6/27    2005/6/30
>
>
>実行結果
>注番  部番  日付1   日付2   日付3    日付4    日付5
>1   あ  2005/7/6  2005/7/1  2005/6/30  2005/6/27    
>
>
>日付5に"2005/6/30"と入るはずなのですが、入りません。
>前の日付とダブっているからなのでしょうか。。。
そうです。そういう仕様で作りました。
実は、最初にk さんが投稿された内容、私は殆ど理解できませんでした。
2回目の投稿から私なりに規則性を探して記述したコードだったのですが、
仕様が違うみたいですね!!

'================================================
Function get_num_value(rng As Range, sushiki) As Variant
  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
    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

get_num_valueを上記に差し替えてみて下さい。
Mainは、前回と同じです。

【26674】Re:重複データを整理したい
質問  YN  - 05/7/13(水) 20:23 -

引用なし
パスワード
   ▼ichinose さん:
▼k さん:

今晩は。
横からお邪魔しましてお許しください。
余りにも難しいコードでついていかれません。
でも何故か興味を持って見させていただいております。

小生も、エクセルにichinose様のコードをコピーさせていただき
動かそうとするのですが、
エラーが発生して、手ずかずです。
コードを見ても分からないのが一番の原因ですが・・・
 If UBound(ans) > maxbnd Then maxbnd = UBound(ans)の列で
 配列がありません のコンパイルエラーが発生します。
何が問題なのでしょうか?
Kさんの方では上手く動いているようですね。
お時間が許せましたら、ご返事いただければ幸いです。
失礼しました。

【26681】Re:重複データを整理したい
発言  ichinose  - 05/7/14(木) 5:57 -

引用なし
パスワード
   ▼YN さん:

おはようございます。
>小生も、エクセルにichinose様のコードをコピーさせていただき
>動かそうとするのですが、
>エラーが発生して、手ずかずです。
>コードを見ても分からないのが一番の原因ですが・・・
> If UBound(ans) > maxbnd Then maxbnd = UBound(ans)の列で
> 配列がありません のコンパイルエラーが発生します。
>何が問題なのでしょうか?
まず、

・WindowsとOfficeのバージョンを教えてください。

・「get_num_value」というFunctionの訂正前、後のコード、それとも
 両方でエラーが発生していますか?

・エラーを確認した元データはどんなものでしょうか?

注番    部番    日付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

kさんが提示されている上記のようなデータではどうでしょうか?
それとも違うデータですか?
それを教えてください。

>If UBound(ans) > maxbnd Then maxbnd = UBound(ans)の列で
>配列がありません

であれば、原因は「get_num_value」にあるような気がしますが・・・。

   If VarType(ans) <> vbBoolean Then
     msgbox vartype(ans) '←とした場合、何が表示されますか?
     If UBound(ans) > maxbnd Then maxbnd = UBound(ans) 

EXCEL2000(Win98),2002(Win2000)でいくつかサンプルを作成して
確認しましたが、再現はできませんでした。

【26683】Re:重複データを整理したい
質問  YN  - 05/7/14(木) 6:58 -

引用なし
パスワード
   ▼ichinose さん:

おはようございます。
ありがとうございます。そして失礼しました。

WindowsとOfficeのバージョン
EXCEL2000(Win98)です。

サンプルは全く同じものを使っております。
多分変数の設定で引っかかっているように感じます。
変数の抜けているものがありましたら、明示していただけませんでしょうか。

 msgbox vartype(ans) '←とした場合、何が表示されますか?
 特に変動はありません。

 やはり
 If UBound(ans) > maxbnd Then maxbnd = UBound(ans)の列で
 配列がありません のコンパイルエラーが発生します。

>
>・「get_num_value」というFunctionの訂正前、後のコード、それとも
> 両方でエラーが発生していますか?

  両方をしていません。訂正後のコードでしています。

>・エラーを確認した元データはどんなものでしょうか?
>
>注番    部番    日付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
>
>kさんが提示されている上記のようなデータではどうでしょうか?
>それとも違うデータですか?
>それを教えてください。

同じデータを使っています。

>EXCEL2000(Win98),2002(Win2000)でいくつかサンプルを作成して
>確認しましたが、再現はできませんでした。

もう少しテストしてみます。
変数の設定で最初からひっかかりました。
抜けている変数が有りました明示していただけませんでしょうか。

では、また夜に見させていただきます。
失礼します。

【26698】Re:重複データを整理したい
お礼  k  - 05/7/14(木) 11:45 -

引用なし
パスワード
   問題なく整理できました。
本当にどうもありがとうございます。
説明が不明瞭でご迷惑をおかけしてすみませんでした。

【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

【26748】Re:重複データを整理したい
お礼  YN  - 05/7/15(金) 21:48 -

引用なし
パスワード
   ▼ichinose さん:

こんばんは、色々と時間を割いていただきありがとうございました。
Option Explicitを外して、動作が問題なくなりました。
すみませんでした。

でも、何故 Option Explicitをつけたままではいけないのでしょうか?
変数の書き間違えなどの自動訂正に便利と本などに書かれているものですから
強制しているのですが・・・

大変お騒がせ致しました。じっくりと勉強させていただきます。

いつもいつもご指導ありがとうございます。

【26749】Re:重複データを整理したい
発言  ichinose  - 05/7/16(土) 0:13 -

引用なし
パスワード
   ▼YN さん:
こんばんは。


>でも、何故 Option Explicitをつけたままではいけないのでしょうか?
>変数の書き間違えなどの自動訂正に便利と本などに書かれているものですから
>強制しているのですが・・・

おしゃられているとおり、
Option Explicit
を付けて変数宣言を強制する事はよいことだと思います。


私の会社では、ローカルルールがあって、
「いくつかの決められた変数名は宣言なしで使用する」
ということにしてあります(賛否両論ありましたが・・)。
例えば、g0〜g6(General variable)
これらは、ちょっとしたワークに使用したり、
配列の添え字だったり用途は様々です。
他にもいくつかあるんですが・・・。
今ところ、ルールだけ決めておけば
宣言なしで使用しても不便を感じないので
このルールに従っています。
(こういうのは他言語での慣例みたいなものも
多分に含んでいたりもするんですけどね!!)

よって
Option Explicit
の記述はしません。

Option Explicit
の有無に関しては
YN さんのおっしゃるとおりだと思います。

ただ、私が今回提示したコードを動かすためにははずしてください

又は、ご自分で変数宣言の手直しをして下さい

ということです。

それと次回からは極力変数宣言をするようにしますね。

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