|
▼Statis さん:
>こんにちは
>
>これで如何でしょうか?
>(Sheet1の1行目は項目行とします。又、Sheet2はすべてのセルが空白である事)
>
>
>Sub Test_Sum()
>Dim Ws As Worksheet, C As Range, R As Range
>Dim Fi As Range, Ad As String, Ma As Variant
>
>Set Ws = Worksheets("Sheet2")
>Application.ScreenUpdating = False
>Ws.Cells.Clear
>With Worksheets("Sheet1")
> .Columns(1).AdvancedFilter xlFilterCopy, , Ws.Range("A1"), True
> .Columns(2).AdvancedFilter xlFilterCopy, , Ws.Range("B1"), True
> With Ws.Range("B2", Ws.Range("B65536").End(xlUp))
> .Copy
> Ws.Range("B1").PasteSpecial xlPasteAll, , , True
> .Clear
> Set R = .Offset(, -1)
> End With
> For Each C In R
> Set Fi = .Columns(1).Find(C.Value, , xlValues, , xlWhole)
> If Not Fi Is Nothing Then
> Ad = Fi.Address
> Do
> Set Fi = .Columns(1).FindNext(Fi)
> Ma = Application.Match(Fi.Offset(, 1).Value, Ws.Rows(1), 0)
> If Not IsError(Ma) Then
> *** C.Offset(, Ma - 1).Value = C.Offset(, Ma - 1).Value + 1
> End If
> Loop Until Ad = Fi.Address
> Set Fi = Nothing
> End If
> Next C
>End With
>Application.ScreenUpdating = True
>Set R = Nothing
>
>End Sub
statis さん こんばんは ありがとうございました
プログラムを走らせたところ 上記の***しるしの行で実行時エラーとなり
型が一致しないと メッセージが出ました 抽出結果はつぎのようになっていました
A a b c
い 1 1
ろ
は
どうしたらよろしいでしょうか
プログラムの理解に苦しんでいます
|
|