Results of 1 - 1 of about 48836 for A�����������������������... (0.009 sec.)
- [[20130401174605]]
- #score: 1420
- @digest: 0c41e4dc0f18c9916f0bb721683009f2
- @id: 61959
- @mdate: 2013-04-07T15:45:53Z
- @size: 13047
- @type: text/plain
- #keywords: rcriteria (52054), 暇人 (16055), 索文 (10532), 不変 (7517), ブロ (7340), 人) (5792), 用配 (5212), 定文 (4033), ト結 (3870), 展開 (3481), areas (3315), xxx (3280), 何個 (3070), xlcelltypeconstants (3070), ロッ (2649), sheet4 (2479), 列: (2282), 領域 (2094), 字列 (2058), 文字 (1964), カウ (1953), ら下 (1895), 空白 (1795), 検索 (1753), 列c (1691), sheets (1633), 元デ (1563), specialcells (1384), 位置 (1382), ubound (1291), range (1236), 果の (1234)
- 『空白セルに挟まれた指定文字列をカウント』（サン）
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列に連なっていること、検索したい範囲は、それぞれ空白に挟まれることは不変です。） Aブロックごとの検索文字列の入力位置が変わった場合は、 どこのマクロの数字を変更すればよろしいでしょうか? 例:Sheet3のA2から下に入力されているものが、Sheet4のB2から下に入力されている場合 （検索文字列はどこからのセルから始まって、順番に下に入力することは不変です。） Bカウント結果の書き出し位置を変更したい場合は、 どこのマクロの数字を変更すればよろしいでしょうか? 例: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行目から最終行まで Aブロックごとの検索文字列の入力位置 Ts = .Range("c2:c" & m).Value '指定文字列 C列 C列:2行目から最終行まで Bカウント結果の書き出し位置 .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 '展開位置 (暇人) ---- @、A、B それぞれに、ここを、こうという連絡はわかりにくいと思うので、以下にこれら条件変更を できるだけ容易にできる構成のコード案を。 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") '検索語シート名 'A検索文字領域 Set rCriteria = Sheets("Sheet4").Range("B2", .Range("B" & .Rows.Count).End(xlUp)) End With 'B結果の書き込み領域 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 (ぶらっと) ---- NBさん GobGobさん お礼が遅くなりまして申し訳ございませんでした＞＜ 関数でもカウントすることが可能なんですね! 大変勉強になりました!ありがとうございました! 暇人さん ぶらっとさん お礼が遅くなりまして申し訳ございませんでした＞＜ お二人のマクロとも見事に私のやりたいことを解決することができました! 感激です! 本当にありがとうございました! もしお時間があれば最後に教えて頂きたいのですが、 検索文字列が今回のようにブロック毎に別々の文字列ではなく、 すべてのブロックに対して、「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") '検索語シート名 'A検索文字領域 Set rCriteria = Sheets("Sheet4").Range("B2", .Range("B" & .Rows.Count).End(xlUp)) End With 'B結果の書き込み領域開始位置 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 (ぶらっと) ---- 暇人さん CODさん ぶらっとさん 皆さま丁寧にご回答頂き本当にありがとうございます! これまた希望通りにカウントすることができました!! 最後まで本当にありがとうございました! 感謝しております! また機会がありましたらよろしくお願い致します! サン... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201304/20130401174605.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97023 documents and 608156 words.
訪問者：