Excelの質問です。種類が同じデータをカウントしたいです<m(__)m>

質問

Excelの質問です。種類が同じデータをカウントしたいのですが、合理的な方法が思い浮かばず悩んでいます(>_<)

インドの紅茶|紅茶(ダージリン)
インドの紅茶(アッサム)
インドの紅茶|紅茶(ニルギリ)
インドの紅茶|紅茶(ドアーズ)

スリランカの紅茶|紅茶(ウヴァ)
スリランカの紅茶|紅茶(ディンブラ)
スリランカの紅茶(ヌワラエリア)
スリランカの紅茶|紅茶(キャンディ)
スリランカの紅茶|紅茶(ルフナ)

中国の紅茶(キームン)
中国の紅茶|紅茶(ラプサンスーチョン)

インドネシアの紅茶(ジャワ)
インドネシアの紅茶|紅茶(スマトラ)

アフリカの紅茶|紅茶(ケニア)

ネパールの紅茶|紅茶(シャングリラ)

日本茶[お茶](茎茶)
日本茶(芽茶)
日本茶[お茶](抹茶)
日本茶(玉露)
日本茶(煎茶)
日本茶[お茶](粉茶)
日本茶(玉緑茶)
日本茶[お茶](ほうじ茶)
日本茶[お茶](玄米茶)
日本茶(手揉み茶)
日本茶(深蒸し煎茶)
日本茶(番茶)

ブラジルの珈琲(ブラジル・サントス)
コロンビアの珈琲[コーヒー](コロンビア)
タンザニアの珈琲(キリマンジャロ)
インドネシア・スマトラの珈琲(マンデリン)
ハワイの珈琲|コーヒー(ハワイ・コナ)
グァテマラの珈琲|コーヒー(グァテマラ)
ジャマイカの珈琲|コーヒー(ブルーマウンテン)
アラビア・エチオピアの珈琲(モカ)
ケニアの珈琲(ケニア)
・
・
・
データ数は37個(この例では)なのですが、データの種類は、「インドの紅茶」「スリランカの紅茶」「中国の紅茶」「インドネシアの紅茶」「アフリカの紅茶」「ネパールの紅茶」「日本茶」「ブラジルの珈琲」「コロンビアの珈琲」「タンザニアの珈琲」「インドネシア・スマトラの珈琲」「ハワイの珈琲」「グァテマラの珈琲」「ジャマイカの珈琲」「アラビア・エチオピアの珈琲」「ケニアの珈琲」の、16個です。

このようなデータが、C列にずらっと並んでいます。

種類だけをカウントするには、まず()内を削除→[]内を削除→|(縦棒)より後ろを削除→重複するデータを削除→データ数を数える・・・というプロセスを進んでいけばよいと思いましたので、「[*]」を空白に置換→「(*)」を空白に置換→「|*」を空白に置換→フィルタオプションで重複を削除→COUNTA関数でデータ数をカウント→Sheet2のA1セルにデータ数を貼り付け・・・と、マクロを記録していきました。すると、

Sub Macro4()
'
' Macro4 Macro
'

'
Columns("A:A").Select
Selection.Replace What:="[*]", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(*)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="|*", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A6:A25").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
With ActiveWindow
.Top = 10.75
.Left = 76
End With
Sheets("Sheet2").Select
ActiveCell.FormulaR1C1 = "=COUNTA(Sheet1!R[6]C:R[1048575]C)"
End Sub

となったのですが、Sheet2のA1には「37」と出てしまいました(ToT)
16が出ると思ったのですが・・・何か良い方法はないでしょうか？
よろしくお願いします(>_<)

回答No.11

merlionXX · ベストアンサー

merlionXXです。

> マクロは全然うまく稼働し、問題は解決されてはいるのですが、もしお暇なとき可能であれば、意味もおしえていただければ

今回、データ数がどれくらいあるのかわからなかったので、たくさんあっても時間がかからなくするためにセル範囲を一旦配列（w）に取り込み、配列内でチェックしています。
また、文字列から不要部分を区切る記号"[,(,|"が登場する順序に規則性があるかないか不明のため、一旦全部を調べ、その文字列内での登場順番を配列（x）に取り込んで、最小値を取得しています。
そのため、かなり複雑になってしまいました。

もし、
データはせいぜい千件程度のレベルである。
データ内に空白行はない。
"[,(,|"が登場する順序に規則性がある。
"[,(,|"が存在しないデータはない。
などと、条件をつけられるのでしたらもっとずっと簡単にできたのですが。（本来、質問時にこのような条件はあるのかないのか明示すべきとは思いますが）

一応、逐条解説を付し、わかりやすいように別シートに重複無しのデータをリストアップするようにしてみました。

Sub test04()
Dim myDic As Object, myStr As String, i As Long, n As Long, k As Integer, m As Integer, y As Integer
Dim w, sp '以上は変数宣言
Set myDic = CreateObject("Scripting.Dictionary") '重複を排除するためDictionaryオブジェクトを作成
w = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp)).Value '高速化のためデータ範囲を配列ｗに代入
sp = Split("[,(,|", ",") 'データから不要部分を区切る文字列を配列spに代入
For i = LBound(w, 1) To UBound(w, 1) 'iは配列wの最初から最後までの数
m = 0: ReDim x(0) '変数mをクリア、動的配列xをクリア
If w(i, 1) <> "" Then '変数wのi番目が空白でなければ
For n = LBound(sp) To UBound(sp) 'nは配列spの最初から最後までの数
k = InStr(w(i, 1), sp(n)) 'kは変数wのi番目の文字列にsp（"[,(,|"）がある位置
If k > 0 Then 'spがあれば
ReDim Preserve x(m) '動的配列xの要素数をm個に増やす
x(m) = k '配列xのm番目にkを代入
m = m + 1 'mの値を増やす
End If
Next n '次のnに繰り返す
y = WorksheetFunction.Min(x()) '配列xのうち最小値をyに代入
If y > 0 Then 'yが0より大きければ（"[,(,|"があれば）
myStr = Left(w(i, 1), y - 1) '変数wのi番目のその前までをmyStrに代入
Else 'yが0ならば（"[,(,|"がなければ）
myStr = w(i, 1) '変数wのi番目をそのままmyStrに代入
End If
If Not myDic.exists(myStr) Then 'myStrが重複しなければ
myDic.Add myStr, y 'DictionaryのKeyに追加し、Itemにy値を関連付ける
End If
End If
Next i '次のiに繰り返す
Worksheets.Add '確認のため新規シートを追加
ActiveSheet.Range("A1").Resize(myDic.Count).Value = Application.Transpose(myDic.Keys) 'A1以下にKeyを縦に転記
ActiveSheet.Range("B1").Resize(myDic.Count).Value = Application.Transpose(myDic.Items) 'B1以下にItemを縦に転記
MsgBox "データの種類: " & myDic.Count
End Sub

お礼

すいません、私の質問が非常に曖昧でした(>_<)
回答していただける方にも失礼ですよね、「A列にデータがある」と、質問では言ってるのに、私はマクロの記録をC列にデータがある状態でやってしまっていますし・・・(汗)

"[,(,|"に規則性はなく、"[,(,|"が全くないデータもあります。データは2000ぐらいです。ほんと、気をつけたいと思います<m(__)m>

てかすごいですね、別シートのA列に種類のデータが出現し、B列には"[,(,|"が最初に出現する番号が出てきました。

ほんと脱帽です。
丁寧に解説していただいたので、なんとか理解できそうです。For～Nextステートメントとか、何かいろんな技が複雑に絡み合ってる感じなので勉強になります(^_^;)
LBoundやUBoundは難しそうですが(笑)
http://hpcgi1.nifty.com/kenzo30/b_cbbs/cbbs.cgi?mode=al2&namber=30645&no=0&P=R&KLOG=199
ありがとうございました<m(__)m>

回答No.10

KURUMITO

回答Ｎｏ3です。
遅くなってごめんなさい。
Ｄ2セルには次の式を入力して下方にオートフィルドラッグします。
=IF(ISERROR(FIND("紅茶",C2)),"",LEFT(C2,FIND("紅茶",C2)+1))&IF(ISERROR(FIND("日本茶",C2)),"",LEFT(C2,FIND("日本茶",C2)+2))&IF(ISERROR(FIND("珈琲",C2)),"",LEFT(C2,FIND("珈琲",C2)+1))

回答Ｎｏ3ではLEFT(C2,FIND("日本茶",C2)+1)でしたが、＋2にすることで日本茶と表示されます。紅茶は2文字で＋1ですが日本茶は3文字で＋２、4文字の場合には＋3のようになります。

お礼

すごいですね、こんな関数の組合せ、全然私では思いつきません(>_<)
=FIND("紅茶",C2)で「5」と出てしまうから、Left関数で抽出する際は+1をしなければならないのですね～すごく勉強になりました！
ありがとうございます<m(__)m>

回答No.9

imogasi

#8です。
３種の記号のうち、最も始めに出てきた直前までを、「種類」にする、と言う表現で質問の題意が満たせるなら、＃８の冗長な部分が下記で是正されると思い挙げてみます。
ーーー
Sub test02()
d = Range("A65536").End(xlUp).Row
Dim shu(100)
n = 1
'----
For i = 1 To d
x = Cells(i, "A")
If x <> "" Then
'--
p = InStr(x, "(")
q = InStr(x, "|")
r = InStr(x, "[")
'--0以外で最小の探索。0はその記号が見つからず、の場合です
If p = 0 Then p = 999
If q = 0 Then q = 999
If r = 0 Then r = 999
'--
m = WorksheetFunction.Min(p, q, r)
If m = 999 Then
m = Len(x) + 1
End If
' MsgBox Mid(x, 1, m - 1) & "=" & m
'---既出の種類と比較
For j = 1 To n - 1
If shu(j) = Mid(x, 1, m - 1) Then GoTo p1 '既にあり
Next j
shu(n) = Mid(x, 1, m - 1) '新顔なので追加
n = n + 1
'--
p1:
End If
Next i
'--内容表示・確認
For k = 1 To n - 1
Cells(k, "D") = shu(k)
Next k
End Sub
ーー
種類の件数はn-1です。
種類の文字数は998文字以下としてます。
種類数９９種まで。
いずれもコードを変えると拡張可能。
記号が１０種ぐらいまでなら、上記コードの一部修正で対処可能かと思う。

お礼

imogasiさんいつも回答していただきありがとうございます(^_^;)
imogasiさんが書いてくださった#8と#9、実行してみたところ、#8はメッセージボックスが出てきて、一番下にあるデータの行番号が表示され、さらにD列に、種類だけのデータが出現しました！
#9は、D列に種類だけのデータが出現しました！

本当にありがとうございます(>_<)

ちょっとがんばって解読してみました。

空白でなければ・・・If x <> "" Then

p = InStr(x, "(")
q = InStr(x, "|")
r = InStr(x, "[")

"("と"|"と"["を、先頭から探して・・・あっ、なるほどです、999文字まで、"("と"|"と"["が見つかるまで探してくれるみたいですね(驚)

WorksheetFunctionというのは、よくわからなかったのですが、ワークシートで使える関数を、VBAでも使うために、imogasiさんは書いてくださったのではないかと(^_^;)
http://www.relief.jp/itnote/archives/001834.php

最小値mが999(p,q,rが0)だった場合は、1を加えてm=1000に？

MsgBox Mid(x, 1, m - 1) & "=" & m

Mid(x, 1, m - 1) というは、xというセルの最初の文字から、m-1番目までの文字列を取りだすのですか・・・すいません、ここからのコードが全然わかりません(ToT)

MsgBox Mid(x, 1, m - 1) & "=" & m

は、どういう意味なのでしょうか？mと等しい時に、何かするのですか？
また、「p1」というのは、どこにも定義されていないのに、なぜ出てきたのでしょうか？

ほんと図々しくてすいません、お暇な時にお答いただければ幸いです(>_<)

回答No.8

imogasi

質問者の路線でやっているところ、他のやり方になるが私もやってみました。思考を乱しますが、落ちついたらこちらも見てください。
コード
配列に異種のものの文字列を溜め込んで行きます。
Sub test01()
d = Range("A65536").End(xlUp).Row
Dim shu(100)
n = 1
MsgBox d
For i = 1 To d
x = Cells(i, "A")
'--
p = InStr(x, "(")
q = InStr(x, "|")
r = InStr(x, "[")
'--
If r <> 0 Then
For j = 1 To n
If shu(j) = Mid(x, 1, r - 1) Then GoTo p1
Next j
shu(n) = Mid(x, 1, r - 1)
n = n + 1
GoTo p1
End If
'--
If q <> 0 Then
For j = 1 To n
If shu(j) = Mid(x, 1, q - 1) Then GoTo p1
Next j
shu(n) = Mid(x, 1, q - 1)
n = n + 1
GoTo p1
End If
'--
If p <> 0 Then
For j = 1 To n
If shu(j) = Mid(x, 1, p - 1) Then GoTo p1
Next j
shu(n) = Mid(x, 1, p - 1)
n = n + 1
GoTo p1
End If
p1:
Next i
'--確認
For k = 1 To n
Cells(k, "D") = shu(k)
Next k
End Sub
ーー
質問の例で
（｜[ は半角とした。
結果
シートD列に
インドの紅茶
スリランカの紅茶
中国の紅茶
インドネシアの紅茶
アフリカの紅茶
ネパールの紅茶
日本茶
｜と[と（の出現順序について、２つ以上出現する場合、この順で先に来ると言う仮定になっている。この点質問者の情況はどうかな。
質問にこれを書いておく必要が有るのかも。この仮定が置けないなら
ｐ、ｑ、ｒの最小分、すなわち早く出てきた記号を探してその記号までを切り取るロジックに修正しないとならない。

回答No.7

merlionXX

merlionXXです。
再修正させてください。失礼しました。（区切り記号のない場合に不備がありました。）

Sub test03()
Dim myDic As Object, myStr As String, i As Long, n As Long, k As Integer, m As Integer, y As Integer
Dim w, sp
Set myDic = CreateObject("Scripting.Dictionary")
w = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp)).Value
sp = Split("[,(,|", ",")
For i = LBound(w, 1) To UBound(w, 1)
m = 0: ReDim x(0)
If w(i, 1) <> "" Then
For n = LBound(sp) To UBound(sp)
k = InStr(w(i, 1), sp(n))
If k > 0 Then
ReDim Preserve x(m)
x(m) = k
m = m + 1
End If
Next n
y = WorksheetFunction.Min(x())
If y > 0 Then
myStr = Left(w(i, 1), y - 1)
Else
myStr = w(i, 1)
End If
If Not myDic.exists(myStr) Then
myDic.Add myStr, y
End If
End If
Next i
MsgBox "データの種類: " & myDic.Count
End Sub

回答No.6

merlionXX

#4 merlionXXです。
データをよく見たら区切りの記号は複数ある場合もあったのですね。
修正します。

Sub test02()
Dim myDic As Object, myStr As String, i As Long, n As Long, k As Integer, y As Integer
Dim w, sp, x()
Set myDic = CreateObject("Scripting.Dictionary")
w = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp)).Value
sp = Split("[,(,|", ",")
For i = LBound(w, 1) To UBound(w, 1)
If w(i, 1) <> "" Then
For n = LBound(sp) To UBound(sp)
k = InStr(w(i, 1), sp(n))
If k > 0 Then
ReDim Preserve x(n)
x(n) = k
End If
Next n
y = WorksheetFunction.Min(x())
If y > 0 Then
myStr = Left(w(i, 1), y - 1)
Else
myStr = w(i, 1)
End If
If Not myDic.exists(myStr) Then
myDic.Add myStr, y
End If
End If
Next i
MsgBox "データの種類: " & myDic.Count
End Sub

お礼

いつもありがとうございます。このマクロもうまくいきました、「データの種類:16」というメッセージボックスが出てきました！
my Dic、my Str、i、n、k、y、w、p、こんなに多く変数が登場するマクロ、初めて見ました(^_^;)ちゃんと意味も調べてみました。

まず、Split関数の構文は、

Split(expression,delimiter,limit,compare)

だそうで。delimiterって英語の辞書にも載ってるんですね、「区切り文字」という意味でした。つまり「[,(,|」がある箇所を、","(コンマ)によって区切る、splitするのですね。

LBoundとUBound、これも調べてみたのですが、
http://pc.nikkeibp.co.jp/article/NPC/20070803/279065/?P=2
によれば、For i = LBound(w, 1) To UBound(w, 1)・・・は、C列の上限の値から下限の値までを対象として選択しているようですね・・・たぶん(^_^;)

もしC列のデータが空白でなければ・・・If w(i, 1) <> "" Then
sp=指定した区切り箇所を、コンマによってデータを切り取る。・・・For n = LBound(sp) To UBound(sp)

InStr関数も、あまり詳しくないので調べたのですが、文字列の先頭から指定した値を検索してくれるみたいで。
http://officetanaka.net/excel/vba/function/InStr.htm

w(i, 1)を対象として、sp(n)を検索・・・k = InStr(w(i, 1), sp(n))

ということみたいですね、引数startとcompareは省略されていると。

でまた難しいですね、Re Dim Preserve、配列の再定義？
http://ameblo.jp/tech-note/entry-10116705268.html

でも、

y = WorksheetFunction.Min(x())

の箇所で、「データの種類」に該当する文字列だけを取り出しているのは、何となく窺えます。
x()=x(0)ですよね、さっきコンマで区切ったのが、ココでいきてるんですね～

myStr = Left(w(i, 1), y - 1)

ここで、コンマの一文字を除いているのかと。

If Not myDic.exists(myStr) Then
myDic.Add myStr, y

ここはDictionaryオブジェクトと呼ばれるものですか？
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html
似た例を見つけたのですが、なぜこのコードで、最後の集計を行い、「16」という値を導けるのでしょうか？

すいません、マクロは全然うまく稼働し、問題は解決されてはいるのですが、もしお暇なとき可能であれば、意味もおしえていただければ幸いです(>_<)

回答No.5

mitarashi

#2です。VBAの名誉のために？高速化を図ってみました。
65536個のデータを、16種類のデータと総当たりで比較しました
A,B列ともRangeのまま処理：2分強
A列を一旦配列に入れて処理：40秒強
A,B列とも一旦配列に入れて処理：2秒
単純なコードですが、結構使えるかもしれません。ご参考まで。
（XL2000、Celeron2.4GHz、メモリ256KByte)
Sub test2()
Dim i As Long, j As Long, counter As Long, lastRow As Long
Dim buf As Variant, ref As Variant

lastRow = ActiveSheet.Rows.Count
buf = Range(Range("A1"), Range("A" & lastRow))
ref = Range("B1:B16")
For j = 1 To 16
counter = 0
For i = 1 To lastRow
If buf(i, 1) Like (ref(j, 1) & "*") Then counter = counter + 1
Next i
Range("C" & j).Value = counter
Next j
End Sub

お礼

すいません、ちょっと質問の仕方が悪かったみたいでして・・・データは膨大で、16種類以上ある感じなのです(^_^;)

回答No.4

merlionXX

> このようなデータが、C列にずらっと並んでいます

ご提示のコードではA列のようですが、C列でいいんですね？
一例です。

Sub test01()
Dim myDic As Object, myStr As String
Dim w, sp
Set myDic = CreateObject("Scripting.Dictionary")
w = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp)).Value
sp = Split("|,[,(", ",")
For i = LBound(w, 1) To UBound(w, 1)
If w(i, 1) <> "" Then
For n = LBound(sp) To UBound(sp)
x = InStr(w(i, 1), sp(n))
If x > 0 Then
myStr = Left(w(i, 1), x - 1)
Exit For
Else
myStr = w(i, 1)
End If
Next n
If Not myDic.exists(myStr) Then
myDic.Add myStr, x
End If
End If
Next i
MsgBox myDic.Count
End Sub

お礼

すごいですね、「16」というメッセージボックスが出てきました！

回答No.3

KURUMITO

このようなケースでマクロを組まれることの長所は全くないように思います。マクロでの処理は一般に関数処理に比べて時間がかかります。
次のように作業列を組むことで比較的簡単に処理できるように思いますがいかがでしょう。
例えばＣ列の2行目からお示しのデータが並んでいるとします。
Ｄ2セルには次の式を入力して下方にオートフィルドラッグします。
=IF(ISERROR(FIND("紅茶",C2)),"",LEFT(C2,FIND("紅茶",C2)+1))&IF(ISERROR(FIND("日本茶",C2)),"",LEFT(C2,FIND("日本茶",C2)+1))&IF(ISERROR(FIND("珈琲",C2)),"",LEFT(C2,FIND("珈琲",C2)+1))
Ｅ2セルには次の式を入力し下方にオートフィルドラッグします。
=IF(D2="","",IF(COUNTIF(D$2:D2,D2)=1,MAX(E$1:E1)+1,""))
E列での最大値が種類の数ということになります。
別のセルに表示させるのでしたら=MAX(E:E)でも良いでしょう。

お礼

こんなやり方もあるんですね、ありがとうございます(^_^;)
KURUMITOさんの関数を実行すると、E列には、データの種類毎に「0」と、記載されました！
この0を、カウントすればいいんですよね？

D列は、C列の余計なデータを修正し、種類毎のデータに変化させてくれました。ただ、「日本茶・・・」だけは、「日本」と表示されてしまいました(>_<)他は「スリランカの紅茶」「ブラジルの珈琲」と、種類毎にデータの余計な部分をしっかり除いてくれ、ちゃんと表示されました！

「日本茶」と表示されるべき箇所が「日本」と表示されたのは、KURIMOTOさんが書いてくださった難しい関数にその謎がありますよね、じっくり考えてみたいと思います<m(__)m>

回答No.2

mitarashi

難しく考えなければ、
調査対象がA列にあるとして、
調べる対象種類が判明しているなら、それをB列に並べておき、
カウントした結果を隣のセル（C列）に記入するすご～く単純なコードです。
総当たりなので、それなりに時間がかかります。
i = 1 to activesheet.rows.count（当方XL2000なので、65536）にしてやってみると、Celeron2.4GHzで、1分前後かかりました。5000個くらいまでは、我慢できると思います。データがもっと沢山ある場合は、補足でお知らせいただくか、コーヒーを飲みに行く前に仕掛けてください。
Sub test()
Dim i As Long, j As Long, counter As Long

For j = 1 To 16
counter = 0
For i = 1 To 100 'A列のデータ数は適当にいじってください
If Range("A" & i).Value Like (Range("B" & j).Value & "*") Then counter = counter + 1
Next i
Range("C" & j).Value = counter
Next j
End Sub

お礼

調べる対象種類は判明しておりません(たぶん16種類以上あります)ので、mitarashiさんのコードを、

Sub test()
Dim i As Long, j As Long, counter As Long

For j = 1 To 100
counter = 0
For i = 1 To 1000 'A列のデータ数は適当にいじってください
If Range("A" & i).Value Like (Range("B" & j).Value & "*") Then counter = counter + 1
Next i
Range("C" & j).Value = counter
Next j
End Sub

と書きかえて実行したところ、C列に「1」と「0」と「1000」の文字が、何らかの法則性によってずらっ～と並べられまして、でも、うまくカウントすることはできませんでした・・・難しいですね(>_<)

回答No.1

fujillin

実行後のSheet1を見てみればわかるはずです。

COUNTA（範囲）
という関数は、指定範囲内でデータが入っているセルの個数を得る関数です。
値の内容を判断したり、重複を省く関数ではありませんので、データが入っているセルの数を数えるだけです。
それなので、表示通り37になりますよね？
（手動でやっても、同じ結果（＝37）になったはずですが？）

重複を省いてカウントするには、
Dictionaryを利用してカウントするとか、重複しているものを先に削除しておいてCOUNTAで数えるとか、フィルタの重複を無視するを利用するとか、何らかの方法で重複を省く工夫が必要になります。

ついでながら…
（多分、自動記録を利用していると思いますが）
With ActiveWindow
.Top = 10.75
.Left = 76
End With
は、多分処理に関係ないと想像されますが、もし必要なければ除いておいた方が懸命かと…

また、最後のところで
Sheets("Sheet2").Select
ActiveCell.FormulaR1C1 = "=COUNTA(Sheet1!R[6]C:R[1048575]C)"
とR1C1形式で指定しているようですが、Sheet2のアクティブセルって常に決まっているのでしょうか？（どうもそうではない気がします。）

数を入れる場所が決まっているなら、Range(○○)と直接指定するとかのほうが間違えがなくなるでしょう。
また、もしもCOUNTAを使うにしても、範囲指定はA:Aのような指定方法にしておいたほうが確実だと思います。（別シートだし、位置がA列と決まっているようなので）

もっとも、この処理の場合は、必ずしも式を定義しなくても、結果の値だけをセルに入れてあげてもよさそうですが…

お礼

なるほど、必要のない箇所がいっぱいあることがわかりました！
ありがとうございます(>_<)