ExcelVBA一致しない場合その他の行に集計する

質問

「ExcelVBA複数条件一致後別シートに結果表示」という質問を以前させていただき、丁寧にコードを解説していただきました。
※その節はありがとうございました。

●ファイルの内容(概要)配下の通りの構成です。
　＜Sheet1＞
　　A列：性別(男性:1、女性:2でコード化)
　　B列：死因コード(数値5～6桁)
　　C列：年齢
　　D列：市町村(3桁でコード化「201」等)

　＜Sheet2＞Sheet1で条件に一致したものを以下の通り表を作成する
　　・「セルA1」に表にしたい市町村コードをあらかじめ入力しておく
　　・セルB1～セルEC1まで死因コード
　　・セルA2～セルA132まで年齢0～130
　　・セル範囲B2～EC132に「A1」に入力した市町村コードの男性の値が入る
　　・セルB133～セルEC133まで死因コード
　　・セルA134～A264まで年齢0～130
　　・セル範囲B134～EC264に「A1」に入力した市町村コードの女性の値が入る

そして、以下のコードを教えていただきました。

****************************************************

Dim r As Long
Dim i As Integer, j As Integer, k As Integer
Dim Wsf As Object
Dim SCode As Range, Nenrei As Range
Dim Ws1 As Worksheet, Ws2 As Worksheet
Set Ws1 = Worksheets("sheet1")
Set Ws2 = Worksheets("sheet2")
Set Wsf = Application.WorksheetFunction

Application.ScreenUpdating = False

Ws2.Range(Ws2.Cells(2, 2), Ws2.Cells(132, 133)).ClearContents
Ws2.Range(Ws2.Cells(134, 2), Ws2.Cells(264, 133)).ClearContents

With Ws2
Set SCode = .Range(.Cells(1, 1), .Cells(1, 133))
　↑ここはこのように書いていただいたのから、
　指定の死因分類があったためシートから参照するようコードを変えています。
　手元にファイルが無くてかけないのが初心者の情けないところです。
　申し訳ありません。※シートは同一ファイル内におくようにしています。
End With

r = 2
Do While Ws1.Cells(r, 1).Value <> ""
If Ws1.Cells(r, 4).Value = Ws2.Cells(1, 1).Value Then

If Ws1.Cells(r, 1).Value = 1 Then
i = 1
ElseIf Ws1.Cells(r, 1).Value = 2 Then
i = 134
End If

With Ws2
Set Nenrei = .Range(.Cells(i, 1), .Cells(i + 130, 1))
End With

j = i + Wsf.Match(Ws1.Cells(r, 3).Value, Nenrei, 0) - 1
k = Wsf.Match(Ws1.Cells(r, 2).Value, SCode, 0)

Ws2.Cells(j, k).Value = Ws2.Cells(j, k).Value + 1
Else
End If

r = r + 1
Loop

Application.ScreenUpdating = True
Set Scode = Nothing
Set Nenrei = Nothing
Set Wsf = Nothing
Set Ws1 = Nothing
Set Ws2 = Nothing

End Sub

****************************************************

表はあらかじめ作成しておくので、そこに集計結果が入ります。
実行していたら、古いファイルに不詳の死因コードが登場し、
どうしたらいいかと考えた結果、死因コードの列の最後に「その他」を設け、
死因コードに一致しない場合にはそこに集計結果をカウントすることは
できないか？という考えに至りました。

自分で考えるのが一番勉強になると分かっていても試行錯誤している時間が無く、
急ぎのためお知恵のある方々にご協力を頂ければと思い、
再度質問させていただいた次第です。

前の質問は↓こちらです。
http://okwave.jp/qa/q8356291.html

何卒よろしくお願い申し上げます。

回答No.2

ki-aaa · ベストアンサー

これでどうかな

Ws2.Range(Ws2.Cells(2, 2), Ws2.Cells(132, 134)).ClearContents '****修正
Ws2.Range(Ws2.Cells(134, 2), Ws2.Cells(264, 134)).ClearContents '****修正

With Ws2
Set SCode = .Range(.Cells(1, 1), .Cells(1, 134)) '****修正
' ↑ここはこのように書いていただいたのから、
' 指定の死因分類があったためシートから参照するようコードを変えています。
' 手元にファイルが無くてかけないのが初心者の情けないところです。
' 申し訳ありません。※シートは同一ファイル内におくようにしています。
End With

r = 2
Do While Ws1.Cells(r, 1).Value <> ""
If Ws1.Cells(r, 4).Value = Ws2.Cells(1, 1).Value Then

If Ws1.Cells(r, 1).Value = 1 Then
i = 2 '****修正
ElseIf Ws1.Cells(r, 1).Value = 2 Then
i = 134
End If

'With Ws2
'Set Nenrei = .Range(.Cells(i, 1), .Cells(i + 130, 1))
'End With

'j = i + Wsf.Match(Ws1.Cells(r, 3).Value, Nenrei, 0) - 1
j = i + Ws1.Cells(r, 3).Value '****お好みで修正

On Error Resume Next '対象死因分類がないときエラーになるので
k = Wsf.Match(Ws1.Cells(r, 2).Value, SCode, 0)
If Err.Number Then
k = Range("EC1").Offset(, 1).Column
'k = 134 '****直前のコードでもこのコードも同じです。お好みで
End If
On Error GoTo 0

Ws2.Cells(j, k).Value = Ws2.Cells(j, k).Value + 1
Else
End If

お礼

ありがとうございました！やりたいことが実現できました！しかも少し手を加えるだけだったので、とても助かりました！本当に感謝です。

回答No.1

bin-chan

一致しない行数 ＝ 全行数 ー 一致した行数
で求めては？