[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『空白セルに挟まれた指定文字列をカウント』（サン）
A B
1 空白
2 ABC
3 BCA
4 BBB
5 ACC
6 空白
7 ABB
8 BBB
9 BBB
10 空白
11 xxx
12 xxx
13 xxx
14 空白
15 xxx
16 xxx
17 xxx
18 xxx
19 xxx
20 xxx
21 空白
22 xxx
23 xxx
24 xxx
25 xxx
26 空白
27 xxx
28 xxx
29 xxx
30 空白
上表のようにA2から下に空白セルに囲まれた文字列が並んでいます。
最初の空白に挟まれた文字列（A2～A5）に"ABC"という文字列は何個あるか？
次の空白に挟まれた文字列（A7～A9）に"AAA"という文字列は何個あるか？
その次の空白に挟まれた文字列（A11～A13）に"BBC"という文字列は何個あるか？
…づづく
といったようにA列上から順番に指定した文字列が何個あるのかをカウントし別のSheetのA列に個数を入力したい。
指定する文字列はまた別のSheetのA列に上から順番に入力されているものとする。
このようなことをVBAで解決することはできますでしょうか？？ 説明が分かりづらく申し訳ありませんが、 どうか助けて下さい。。＞＜ よろしくお願い致します！！
同一シート上で、下記のようなシート構成として (データA列 : 検索文字C列 : 結果表示 E,F列 )
A B C D E F
1 データ 検索文字 結果
2 a a a 1
3 b b b 2
4 c c c 2
5 d d 2
6 a
7 b
8 c
9 a
10 b
11 c
12
13 a
14 c
15 a
16 c
17
18 a
19 d
20 c
21 a
22 d
23 c
Sub Test()
Dim i&, m&, n&, Co&, T$, Ts, v, w
With Sheets("Sheet1") '適宜変更
m = .Cells(.Rows.Count, "c").End(xlUp).Row + 1
Ts = .Range("c2:c" & m).Value '指定文字列 C列
ReDim w(1 To UBound(Ts), 1 To 2) '展開用配列準備
m = .Cells(.Rows.Count, "a").End(xlUp).Row + 1
v = .Range("a1:a" & m).Value 'データ
T = Ts(1, 1) '検索文字初期値
For i = 2 To UBound(v)
If v(i, 1) = "" Then
n = n + 1
w(n, 1) = T: w(n, 2) = Co: Co = 0
T = Ts(n + 1, 1) '次の検索文字
Else
If v(i, 1) = T Then Co = Co + 1
End If
Next
'展開
.Cells(2, "e").Resize(n, 2).Value = w
End With
End Sub
(暇人)
少しインチキしてるけど。 転記シート（Sheet2) のA列に、最初のブロックの検索文字列、2番目のブロックの検索文字列、3番目の。。。 というように、あらかじめセットされているものとする。
Sub Sample()
Dim r As Range
Dim v As Variant
Dim i As Long
Dim z As Long
Set r = Sheets("Sheet1").Columns("A").SpecialCells(xlCellTypeConstants) '元シート
z = r.Areas.Count
With Sheets("Sheet2") '転記シート
.Columns("B").ClearContents
v = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
For i = 1 To UBound(v, 1)
If i > z Then Exit For
v(i, 2) = WorksheetFunction.CountIf(r.Areas(i), v(i, 1))
Next
.Range("A1").Resize(UBound(v, 1), 2).Value = v
End With
End Sub
(ぶらっと)
すぐのお返事ありがとうございます！
分かりづらい説明にも関わらず、
お二人とも希望通りのマクロを作って下さり大変感謝しております！
解説まで入れて作って下さったのに大変恐縮なんですが、
初心者なもので以下の点質問させて下さい＞＜
①データが入力されている位置が変わった場合は、
どこのマクロの数字を変更すればよろしいでしょうか？
例：A2から下に入力されているものが、C3から下に入力されている場合
（データは、1列に連なっていること、検索したい範囲は、それぞれ空白に挟まれることは不変です。）
②ブロックごとの検索文字列の入力位置が変わった場合は、
どこのマクロの数字を変更すればよろしいでしょうか？
例：Sheet3のA2から下に入力されているものが、Sheet4のB2から下に入力されている場合
（検索文字列はどこからのセルから始まって、順番に下に入力することは不変です。）
③カウント結果の書き出し位置を変更したい場合は、
どこのマクロの数字を変更すればよろしいでしょうか？
例：Sheet2のC2から下に順番に書き出していたものをSheet3のA2から下に書き出すようにする場合
（カウント結果を1列に上から順番に書き出したいというのは不変です。）
以上3点お手数ですが、教えて頂けないでしょうか＞＜？
よろしくお願い致します！
（サン）
関数で C2:=IF(A2="","",A2) C3:INDEX($A$1:$A$500,MIN(IF(COUNTIF($C$2:C2,$A$2:$A$500),"",ROW($A$2:$A$500)))) 配列数式 CTRL+Shift+Enterで確定 書式「;;」 C3を下へコピー 「空白」の取り扱いが難しく、始めの「空白」が「0」としてリストアップされます。(書式により見た目は「空白」) D1～ :1,2,3,・・・・・・・の連番 D2:=COUNTIF($A$1:INDEX($A$1:$A$500,SMALL(IF($A$1:$A$500="",ROW($A$1:$A$500),""),D$1+1)),$C2)-COUNTIF($A$1:INDEX($A$1:$A$500,SMALL(IF($A$1:$A$500="",ROW($A$1:$A$500),""),D$1)),$C2) 配列数式 CTRL+Shift+Enterで確定 下へコピー 右へコピー (NB)
興味があったので同じく関数で。
A B C D E F G 1 検索 1BLO 2BLO 3BLO 4BLO 2 a a 1 2 2 2 3 b b 1 2 1 0 4 c c 1 1 1 2 5 d 0 1 0 2 6 a e 0 0 0 1 7 b 8 c 9 a 10 b 11 d 12 13 a 14 c 15 a 16 b 17 18 a 19 d 20 c 21 a 22 d 23 c 24 e 25
A列データ。C列に検索文字、D列以降にブロック毎の文字数
D1 =IF(COUNTIF($A1:$A25,"")-1<COLUMN(A1),"",COLUMN(A1)&"BLO") D2 =IF(OR($C2="",D$1=""),"",SUMPRODUCT(($A$1:INDEX($A$1:$A$25,SMALL(INDEX(($A$1:$A$25<>"")*10^16+ROW($A$1:$A$25),),COLUMN(B1)))=$C2)*1)-SUM($C2:C2))
D2を下へコピー。D列を右へコピー。
※$A$1:$A$25を実際の範囲+空白1セルを指定。
(GobGob)
勘違いっぽいね。
暇人さんの例表をおかりして。
E2 =IF(COUNTA(C$2:C2)<ROW(A1),"",C2) F2 =IF(E2="","",COUNTIF(INDEX(A$1:A$25,IF(AND(ROW(A1)=1,A$1<>""),1,SMALL(INDEX((A$1:A$25="")*ROW(A$1:A$25),),COUNTA(A$1:A$25)+ROW(A1)-1))):INDEX(A$1:A$25,SMALL(INDEX((A$1:A$25="")*ROW(A$1:A$25),),COUNTA(A$1:A$25)+ROW(A1))),E2))
E2:F2 下へコピー。
(GobGob)
質問の件に関しては、コード内の下記の位置を確認してください。
①データが入力されている位置
v = .Range("a1:a" & m).Value 'データ
A列:2行目から最終行まで
②ブロックごとの検索文字列の入力位置
Ts = .Range("c2:c" & m).Value '指定文字列 C列
C列:2行目から最終行まで
③カウント結果の書き出し位置
.Cells(2, "e").Resize(n, 2).Value = w
E列 2行目へ展開
コードとにらめっこすれば、何処をどう変更するかが理解できるはずです。
色いろとご自分で試してみることが勉強です。それをやらんと次への応用ができません。
なを、元データ、指定文字列、展開場所等のシートが異なる場合は、
それぞれの、Range, Cells へきちんとシート名を指定する必要があります。
例えば v = Sheets("Sheet1").Range("a1:a" & m).Value 'データ
Ts = Sheets("Sheet2").Range("c2:c" & m).Value '指定文字列 C列
Sheets("Sheet3").Cells(2, "e").Resize(n, 2).Value = w '展開位置
(暇人)
①、②、③ それぞれに、ここを、こうという連絡はわかりにくいと思うので、以下にこれら条件変更を できるだけ容易にできる構成のコード案を。
Sub Sample2()
Dim rIn As Range
Dim rOut As Range
Dim rCriteria As Range
Dim v As Variant
Dim i As Long
Dim c As Range
With Sheets("Sheet1") '元データシート名
'①元データ領域の取得
Set rIn = .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
End With
With Sheets("Sheet4") '検索語シート名
'②検索文字領域
Set rCriteria = Sheets("Sheet4").Range("B2", .Range("B" & .Rows.Count).End(xlUp))
End With
'③結果の書き込み領域
Set rOut = Sheets("Sheet3").Range("A2").Resize(rCriteria.Rows.Count)
'処理
ReDim v(1 To rCriteria.Count, 1 To 1) '書込み用配列
For Each c In rCriteria
i = i + 1
v(i, 1) = WorksheetFunction.CountIf(rIn.Areas(i), c.Value)
Next
'結果の書き込み
rOut.Value = v
End Sub
(ぶらっと)
お礼が遅くなりまして申し訳ございませんでした＞＜
関数でもカウントすることが可能なんですね！
大変勉強になりました！ありがとうございました！
暇人さん ぶらっとさん
お礼が遅くなりまして申し訳ございませんでした＞＜
お二人のマクロとも見事に私のやりたいことを解決することができました！
感激です！
本当にありがとうございました！
もしお時間があれば最後に教えて頂きたいのですが、
検索文字列が今回のようにブロック毎に別々の文字列ではなく、
すべてのブロックに対して、「a」または「b」または「c」が含まれている数を
カウントすることも可能でしょうか＞＜？
何度も質問しても申し訳ございませんが、
よろしくお願い致します！
サン
"a" or "b" or "c" を含むブロック数 ? 、それとも、それらを含む、データ数 ? どっちかな ? (暇人)
各ブロック内に、a,b,c を含むデータが何個あるかのサンプルです。 MsgBox で表示するので、あまり大きくないデータで試してください。
Sub TestB()
Dim i&, m&, n&, T$, S$, v
With Sheets("Sheet1") '適宜変更
m = .Cells(.Rows.Count, "a").End(xlUp).Row + 1
v = .Range("a1:a" & m).Value 'データ
m = 0: n = 1
For i = 2 To UBound(v)
S = v(i, 1)
If v(i, 1) <> "" Then
If S Like "*a*" Or S Like "*b*" Or S Like "*c*" Then
m = m + 1
End If
Else
T = T & vbCr & "Block:" & n & " " & m & "ケ"
m = 0: n = n + 1
End If
Next
'展開
MsgBox T
End With
End Sub
(暇人)
Sub TestC()
Dim i&, m&, n&, o&, p&, S$, v
With Sheets("Sheet1") '適宜変更
m = .Cells(.Rows.Count, "a").End(xlUp).Row + 1
v = .Range("a1:a" & m).Value 'データ
m = 0: n = 1: p = 1
For i = 2 To UBound(v)
S = v(i, 1)
If S <> "" Then
o = o + 1
If S Like "*a*" Or S Like "*b*" Or S Like "*c*" Then
m = m + 1
End If
Else
p = p + 1
Cells(p, "c") = "Block: " & n
Cells(p, "d") = "' " & m & "/" & o
m = 0: n = n + 1: o = 0
End If
Next
End With
End Sub
(暇人)
途中参加です。Instrでチェック。
''*文字検索メイン：G列に出力
Sub ATest()
Dim Wr As Range, Myo As Range, Ctr As Long, ix As Long
Set Wr = ActiveSheet.UsedRange.Resize(, 1).SpecialCells(xlCellTypeConstants)
For ix = 1 To Wr.Areas.Count
Ctr = 0
For Each Myo In Wr.Areas(ix)
If InstrMor(Myo.Value) Then Ctr = Ctr + 1
Next
Cells(ix, "G").Value = "Block" & ix & " = " & Ctr
Next
End Sub
''*文字検索サブ
Function InstrMor(P1) As Boolean
Const C1 As String = "a,b,c" '★検索文字をカンマで区切る
Dim W1, i As Long
W1 = Split(C1, ",")
For i = 0 To UBound(W1)
If InStr(1, P1, W1(i), vbTextCompare) > 0 Then InstrMor = True
Next
End Function
（Cod）
要件がよくわからないところもあるけど、指定語が Sheet4のB2から下に書かれているとして。 Sheet1 の C2 から下の各ブロックのなかの、指定後の数の合計をブロックごとに、Sheet3の A2 から下に列挙。 アップ済みのSample2をできるだけ踏まえて。
Sub Sample3()
Dim rIn As Range
Dim rOut As Range
Dim rCriteria As Range
Dim v As Variant
Dim i As Long
Dim c As Range
Dim n As Long
Dim d As Range
With Sheets("Sheet1") '元データシート名
'①元データ領域の取得
Set rIn = .Range("C2", .Range("C" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeConstants)
End With
With Sheets("Sheet4") '検索語シート名
'②検索文字領域
Set rCriteria = Sheets("Sheet4").Range("B2", .Range("B" & .Rows.Count).End(xlUp))
End With
'③結果の書き込み領域開始位置
Set rOut = Sheets("Sheet3").Range("A2")
'処理
ReDim v(1 To rIn.Areas.Count, 1 To 1) '書込み用配列
For Each d In rIn.Areas
n = 0
For Each c In rCriteria
n = n + WorksheetFunction.CountIf(d, c.Value)
Next
i = i + 1
v(i, 1) = n
Next
'結果の書き込み
rOut.Resize(UBound(v, 1)).Value = v
End Sub
(ぶらっと)
皆さま丁寧にご回答頂き本当にありがとうございます！
これまた希望通りにカウントすることができました！！
最後まで本当にありがとうございました！
感謝しております！
また機会がありましたらよろしくお願い致します！
サン
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.