Excel VBA質問箱 IV

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

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


54859 / 76732 ←次へ | 前へ→

【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
0 hits

【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 お礼

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