[[20060304231428]]　『文字列？の検算』（dack）　ページの最後に飛ぶ

『文字列？の検算』（dack）

 このサイトを知って１年余り
 普段はエクセルを使う事も余り無いので
 過去ログから自分の知りたい情報を検索して使っていましたが
 これはどの様にして検索したらいいのか解らなかったので初めて質問します

 Ｄ３からＤ１００までセルの表示形式標準で
 「1(2,3,4)[A(B,C,D)]」や空白が入っています、
 それをＤ１０３から下にＤ３からＤ１００までの
 Aの合計、Bの合計、Cの合計、Dの合計、をＤ列一列出す事は可能でしょうか？

 　　　　　Ｄ
 　　２　[A(B,C,D)]
 　　３　2(3,0,0)
 　　４　1(2,0,4)
 　　５
 　　６　9(0,1,12)
 　　・
 　　・

 上の例なら
 １０３　12　←Aの合計
 １・・　 5　←Bの合計
 １・・　 1　←Cの合計
 １・・　16　←Dの合計
 [Windows98 Excel97]

こんばんは。

 必ず、A(B,C,D)となっているなら
 Excel97でもいけると思うのですが・・・

 Option Explicit

 Sub test()
    Dim r As Range
    Dim cntA As Long, cntB As Long, cntC As Long, cntD As Long

    Application.ScreenUpdating = False
    For Each r In Range("D2", "D100")
      If r.Value <> "" Then
        cntA = cntA + Val(Mid(r.Value, 1, 1))
        cntB = cntB + Val(Mid(r.Value, 3, 1))
        cntC = cntC + Val(Mid(r.Value, 5, 1))
        cntD = cntD + Val(Mid(r.Value, 7, 1))
      End If
    Next
    Range("D103", "D106").Value = Application.Transpose(Array(cntA, cntB, cntC, cntD))
    Application.ScreenUpdating = True

 End Sub
　　　　　　　　　　　　　(SHIOJII)

 おっと、衝突～☆

 携帯からなので、直接の式は書けませんが、、、
配列数式を用いて、IF関数の条件でFIND関数などを使用し、"("や","や")"を探し、文字として抜き取る。それを、SUM関数で足してやるのはどうでしょう？

 （キリキ）(〃⌒o⌒)b

 二桁を考慮していませんでした。
 とりあえず、捨ててください。
　　　　　　(SHIOJII)

 あんまりきれいじゃないですが。
 97はSplitがなかったような。
 Sub Test()
    Dim i As Long
    Dim MyArray As Variant
    Dim Kei(3) As Long
    Dim loc1 As Long, loc2 As Long
    Dim st As String

    MyArray = Range("D3:D100")

    For i = LBound(MyArray, 1) To UBound(MyArray, 1)
        st = Trim(MyArray(i, 1))
        If st <> "" Then
            loc1 = InStr(st, "(")
            Kei(0) = Kei(0) + Val(Left(st, loc1 - 1))
            loc2 = InStr(loc1 + 1, st, ",")
            Kei(1) = Kei(1) + Val(Mid(st, loc1 + 1, loc2 - 1))
            loc1 = InStr(loc2 + 1, st, ",")
            Kei(2) = Kei(2) + Val(Mid(st, loc2 + 1, loc1 - 1))
            loc2 = InStr(loc1 + 1, st, ")")
            Kei(3) = Kei(3) + Val(Mid(st, loc1 + 1, loc2 - 1))
        End If
    Next i
    For i = 0 To 3
        Cells(i + 103, "D").Value = Kei(i)
    Next i

 End Sub
 （やっちん）

 SHIOJIIさん、キリキさん、やっちんさん　有難うございます
 質問して答えが返って来るのがこんなに嬉しい事だとは知りませんでした

 今回は複数シートにわたり、
 日々列が変わって行くのでやっちんさんのVBAを
 毎日修正しながら対応したいと思います＾＾v
 これで何度も電卓を叩く必要が無くなります＾＾;

 （やっちんさん、そうなんですよねぇ97はSplitが無いから皆さんが
 日々ここに提示してくださるｻﾝﾌﾟﾙが実行出来ない時が有るんですよ...
 （dack）

 キリキさんのヒントをモトに具体的な数式を考えてみました。ややこしかった(*_*;)
 って解決しちゃいましたね＾＾；　
 関数だとこんな感じで出来ましたぁ、ということで・・・

 いずれも配列数式としてCtrl+Shift+Enterで確定してください。

 D103に =SUM(IF(D3:D100<>"",--LEFT(D3:D100,FIND("(",D3:D100)-1)))
 D104に =SUM(IF(D3:D100<>"",--LEFT(MID(D3:D100,FIND("(",D3:D100)+1,20),FIND(",",MID(D3:D100,FIND("(",D3:D100)+1,20))-1)))
 D105に =SUM(IF(D3:D100<>"",--LEFT(MID(D3:D100,FIND(",",D3:D100)+1,20),FIND(",",MID(D3:D100,FIND(",",D3:D100)+1,20))-1)))
 D106に =SUM(IF(D3:D100<>"",--RIGHT(LEFT(D3:D100,LEN(D3:D100)-1),LEN(D3:D100)-FIND(",",D3:D100)-FIND(",",MID(D3:D100,FIND(",",D3:D100)+1,20))-1)))

 MID関数の文字数を20としてあるので、「（ 」より右側に20文字以上あるのなら変更してください。
 (かなれっと)

 すいません、おもいっきり間違えていました。
 MID関数で取り出す文字列の長さを修正してます。
 Sub Test()
    Dim i As Long
    Dim MyArray As Variant
    Dim Kei(3) As Long
    Dim loc1 As Long, loc2 As Long
    Dim st As String

    MyArray = Range("D3:D100")
    For i = LBound(MyArray, 1) To UBound(MyArray, 1)
        st = Trim(MyArray(i, 1))
        If st <> "" Then
            loc1 = InStr(st, "(")
            Kei(0) = Kei(0) + Val(Left(st, loc1 - 1))
            loc2 = InStr(loc1 + 1, st, ",")
            Kei(1) = Kei(1) + Val(Mid(st, loc1 + 1, loc2 - loc1 - 1))
            loc1 = InStr(loc2 + 1, st, ",")
            Kei(2) = Kei(2) + Val(Mid(st, loc2 + 1, loc1 - loc2 - 1))
            loc2 = InStr(loc1 + 1, st, ")")
            Kei(3) = Kei(3) + Val(Mid(st, loc1 + 1, loc2 - loc1 - 1))
        End If
    Next i
    For i = 0 To 3
        Cells(i + 103, "D").Value = Kei(i)
    Next i
 End Sub
 （やっちん）

 おはようございます
かなれっとさん、やっちんさん有難う御座います
ここに質問投稿して良かったと思います

 このかなれっとさんが書いた関数式は、
やはり私のスキルで過去ログをどんなに見ても解らなかったですo( _ _ )o ショボーン

 やっちんさん上と下の式　
私が作ったサンプルでは同じように動いたんですが、
どの様になった時にバグを起こすのでしょう？

 結果は変わりません(^^;
 最初のコードは数値の部分を取り出すときに実際より長めに取り出していました。
 例を挙げると「1(2,3,4)」の2番目の数字をMID関数で取り出す場合「2,3」を取り出していました。
 ただ、これをVAL関数で数値に変換すると「2」になります。結果的に2番目の数値を取得しています。
 2番目以降の数値の取り出しでも同じことが起きています。
 結果が正しくても、意図した処理と異なるのでそれは間違った処理です。
 こういう潜在的なバグは後々のメンテナンスに支障をきたす場合があります。
 （やっちん）

 SplitX for 97 を作成してみました

 Sub test()
 Dim a, x, ap As Object, i As Long, b(), title, result
 Set ap = Application.WorksheetFunction
 a = Range("d2:d100").Value
 With ap
     For i = 1 To UBound(a, 1)
         a(i, 1) = .Substitute(.Substitute(.Substitute(.Substitute(a(i, 1), "(", ","), _
        ")", ""), "[", ""), "]", "")
     Next
 End With
 title = SplitX(a(1, 1), ",")
 ReDim result(UBound(title), 1)
 For i = 0 To UBound(title)
     result(i, 0) = title(i)
 Next
 For i = 2 To UBound(a, 1)
     x = SplitX(a(i, 1), ",")
     On Error Resume Next
         IsArray (x)
     If Err.Number = 0 Then
         For ii = 0 To UBound(x)
             result(ii, 1) = Val(result(ii, 1)) + Val(x(ii))
         Next
     End If
     Err.Clear
     On Error GoTo 0
 Next
 With Range("d103")
     .CurrentRegion.Clear
     .Resize(UBound(result, 1) + 1, 2) = result
 End With
 Erase result, a
 End Sub

 Function SplitX(txt, Optional delim As String = " ")
 Dim x(), i As Long, n As Long
 i = 1
 Do
     If Mid(txt, i, 1) = delim Then
         ReDim Preserve x(n)
         x(n) = Left(txt, i - 1)
         txt = Right(txt, Len(txt) - i)
         i = 0: n = n + 1
     End If
     i = i + 1
 Loop Until i > Len(txt)
 If Len(txt) Then
     ReDim Preserve x(n)
     x(n) = txt
 End If
 SplitX = x
 End Function
 (seiya)

 こんにちは
 やっちんさん有難う御座います
 そうなんですか
 やはり「VBAを設計するには後々の事まで考える」が鉄則なんですよね
 数値が変わらないところのを見つけるには
 私はまだまだ修行がたりないかな
 これで明日から仕事がちょっと楽になります(*^.^*)エヘッ

 seiyaさん有難う御座います、、、
 でもここで
 ReDim result(UBound(title), 1)
「実行時エラー'9'インデックスが有効範囲にありません。」
 　　　　　　　というエラーがでます　家のEXCEL97とEXCEL2000でやっても＾＾；

 Dim result
 を
 Dim result()
 に変えてみてください。(seiya)

 あらら、範囲が...

 range("d3:d100")が違っていました。
 range("d2:d100") ですね
 と、思ったら、あってますね？
 D2には
 [A(B,C,D)] がありますか？

 いいえ　私のミスで質問するときに「２」を消すのを忘れていました
[A(B,C,D)]は質問する前に私が付けたものです＾＾；；
D2には関係ないもの（日付）が入っています（dack）

 >D2には関係ないもの（日付）が入っています
 どのようなデータがどの部分に入っているのかわからないと...
 困りましたね、空白に、日付まで混入ですか...(seiya)

 お邪魔様です。
今度は何時お邪魔できるか分からないので回答出来る様な身分じゃないんですけどね。
せっかく作ったのでよかったら試してみてください。
Option Explicit
Sub てすと()
Dim MyA As Variant
Dim MyAry() As Variant
Dim i As Long
Dim j As Long
With Application
    .ScreenUpdating = False
    Sheets.Add After:=Sheets(Sheets.Count)
    With Sheets(Sheets.Count)
        .Range("D1:D98").Value = Sheets("Sheet1").Range("D3:D100").Value
        .Range("D:D").TextToColumns Comma:=True, OtherChar:="(", Other:=True
        MyA = .UsedRange.Value
    End With
    If IsArray(MyA) Then
        ReDim MyAry(1 To UBound(MyA, 2), 1 To 1)
        For j = 1 To UBound(MyA, 2)
            For i = 1 To UBound(MyA, 1)
                If Not IsDate(MyA(i, j)) Then
                    MyAry(j, 1) = MyAry(j, 1) + Val(MyA(i, j))
                End If
            Next
        Next
        With Sheets("Sheet1")
            .Range("D103", .Range("D103").End(xlDown)).ClearContents
            .Range("D103").Resize(UBound(MyA, 2)).Value = MyAry
        End With
        Erase MyA, MyAry
    End If
    .DisplayAlerts = False
        Sheets(Sheets.Count).Delete
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Goto Sheets("Sheet1").Range("D103")
End With
End Sub
#2006/3/5　16:35　
#日付を無視する様にしました。
（SoulMan）

 私の方は、こんな感じです

 Sub test()
 Dim a, x, ap As Object, i As Long, b(), result(3)
 Set ap = Application.WorksheetFunction
 a = Range("d2:d100").Value
 For i = 1 To UBound(a, 1)
     a(i, 1) = Application.Substitute(a(i, 1), "(", ",")
     If InStr(a(i, 1), ",") > 0 Then
        x = SplitX(a(i, 1), ",")
        On Error Resume Next
            IsArray (x)
        If Err.Number = 0 Then
            For ii = 0 To UBound(x)
                result(ii) = Val(result(ii)) + Val(x(ii))
            Next
        End If
        Err.Clear
        On Error GoTo 0
    End If
 Next
 With Range("d103")
     .CurrentRegion.Clear
     .Resize(4) = Application.Transpose(result)
 End With
 Erase result, a
 End Sub

 Function SplitX(txt, Optional delim As String = " ")
 Dim x(), i As Long, n As Long
 i = 1
 Do
     If Mid(txt, i, 1) = delim Then
         ReDim Preserve x(n)
         x(n) = Left(txt, i - 1)
         txt = Right(txt, Len(txt) - i)
         i = 0: n = n + 1
     End If
     i = i + 1
 Loop Until i > Len(txt)
 If Len(txt) Then
     ReDim Preserve x(n)
     x(n) = txt
 End If
 SplitX = x
 End Function
  (seiya)
 SoulManさんのはなぜか、結果が3種類ですね？

 >SoulManさんのはなぜか、結果が3種類ですね？
失礼しました。引数を省略し過ぎていました。m(__)m
ちょっと訂正してみましたのでお試し下さい。
あぁ～～、、たまに回答するとあせるわ(^^;
（SoulMan）

 SoulManさん、お久しぶりです～♪
 待ってました＾＾

 >今度は何時お邪魔できるか分からないので回答出来る様な身分じゃないんですけどね。
 そんなこと言わずに、ちょいちょい来て下さいよ～

 （キリキ）(〃⌒o⌒)b

 >空白に、日付まで混入ですか...
 seiyaさんどうもすいませんでした
私は初めに
 「Ｄ３からＤ１００までのAの合計、Bの合計、Cの合計、Dの合計、をＤ列一列出す事は可能でしょうか」
 と聞いていますのでＤ２の事はVBAに関係ないだろうと思い日付の事は書きませんでした。

 SoulManさん有難う御座いました
お久しぶりにSoulManさんのVBAを私の質問に回答くださって、、、
 お二人の回答も出来ました＾＾
 （dack）

 解決したようですね。
 Excel97で使用できるように Split/Join 関数を作ってみました。
 使用方法はすべてオリジナルに準拠したつもりです。
 よかったら使ってみてください。

 Function Split(Expression, Optional delimiter, _
                 Optional limit As Long = -1, Optional Compare _
                 As VbCompareMethod = vbTextCompare)
 Dim x(), i As Long, n As Long, y As Long
 ReDim x(0)
 If limit = 0 Or Expression = "" Then Split = x: Exit Function
 Expression = CStr(Expression)
 If limit = 1 Then _
    x(0) = Expression: Split = x: Exit Function
 If IsMissing(delimiter) Then delimiter = Chr(32)
 y = Len(delimiter)
 i = 1
 Do
     If StrComp(Mid(Expression, i, y), delimiter, Compare) = 0 Then
         ReDim Preserve x(n)
         x(n) = Left(Expression, i - 1)
         Expression = Right(Expression, Len(Expression) - i - y + 1)
         n = n + 1
         If limit <> -1 Then _
         If n >= limit - 1 Then Exit Do
         i = 0
     End If
     i = i + 1
 Loop Until i > Len(Expression)
 If Len(Expression) Then
     ReDim Preserve x(n)
     x(n) = Expression
 End If
 Split = x
 End Function

 Function Join(SourceArray, Optional delimiter) As String
 Dim e As Variant
 On Error GoTo Last
 If UBound(SourceArray) = -1 Then Exit Function
 If IsMissing(delimiter) Then delimiter = Chr(32)
 For Each e In SourceArray
     Join = Join & e & delimiter
 Next
 Join = Left(Join, Len(Join) - Len(delimiter))
 Last:
 End Function

 (seiya)

 こんばんは＾＾
今日、提示してもらった式やVBAを会社の本番データをコピーしてやって見ました
思いどうりの結果がでました＾＾ｖ

 それで上のseiyaさんのSplitを試しにやって見たんですが、、、
  Function Split(Expression, Optional delimiter, _
                 Optional limit As Long = -1, Optional Compare _
                 As VbCompareMethod =
 ここが青く光って
「コンパイルエラー：
 　このオートメーションタイプはVisualBasicではサポートされていません」
 　というエラーが出ます。。。
 （dack）

 遅くなりました。

  Function Split(Expression, Optional delimiter, _
                 Optional limit As Long = -1, Optional Compare _
                 As As Long)

 に変更してみてください。
 もしこれでOKならば、各引数の説明をします。(seiya)

 頭の体操を兼ねて...... 
 皆さんマクロですが、私はマクロが駄目なので関数でチャレンジしてみました。

 D103=SUM(IF(D3:D100="","",--MID(D3:D100,1,FIND("(",D3:D100)-1)))
 D104=SUM(IF(D3:D100="","",--MID(D3:D100,FIND("(",D3:D100)+1,FIND(",",D3:D100)-FIND("(",D3:D100)-1)))
 D105=SUM(IF(D3:D100="","",--MID(D3:D100,FIND(",",D3:D100)+1,FIND(",",D3:D100,FIND(",",D3:D100)+1)-FIND(",",D3:D100)-1)))
 D106=SUM(IF(D3:D100="","",--MID(D3:D100,FIND(",",D3:D100,FIND(",",D3:D100)+1)+1,LEN(D3:D100)-FIND(",",D3:D100,FIND(",",D3:D100)+1)-1)))

 配列ですので、Ctrl + Shift + Enter です。
                        ふゥ～....。朝から疲れた～。
　　　　　　　　　　　　　　　　　　　　　　　　　　　　(SS)

 seiyaさんSSさん、こんばんは
 seiyaさんの修正、最初は動かったんですが、「As」をひとつ取り除いたら
 私のマクロでも、他の
[[20050423175641]]の中のSplitを使ったマクロでも動いてくれました＾＾
 SSさんの式でもできました＾＾（でもこの式朝からやってくれたなんて
 （dack）

 >「As」をひとつ取り除いたら.....
 失礼しました！
 でも動いてよかったです。

 以下、引数の説明です。
 例:
 myString="Me And You And She And He"

 Split(myString,"And",-1)

 Split(文字列,区切り文字列,分割数,comparemode)

 文字列はいいですよね？
 区切り文字は「半角スペース」が規定値になっています。
 分割数の規定値は-1で最大分割。
 compareの規定値はnullです。
 ...null - Option Compare で指定したcompare methodを使用。
 ...  0  - Binary compare - 大文字/小文字を区別する。
 ...  1  - Text compare - 大文字/小文字を区別しない。

 以下、適当に試してください。

 msgbox join(split(myString,"And",2,1)
 msgbox join(split(myString,"and")
 ....
 (seiya)

 seiyaさん　ありがとう御座います
 お家に帰ってからゆっくりやってみたいと思います＾＾
 （dack）

コメント返信：

[ 一覧(最新更新順) ]

[[20060304231428]] 『文字列？の検算』（dack） ページの最後に飛ぶ

[[20060304231428]]　『文字列？の検算』（dack）　ページの最後に飛ぶ