[[20140928144336]] 『表の集計表示』(daddy) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『表の集計表示』(daddy)

表1から条件に従い表2を作成したいのですが、やたら作業列が多くなりお手上げです。
簡単な式があればご教授ください。
マクロであれば、注釈付きでお願いします。(まとんど無知です)

表1

 名称	印	イ	ロ	ハ
 あ	*	1	0	0
 あ	-	0	0	1
 あ	-	1	0	0
 あ	*	0	0	0
 あ	*	1	0	1
 い	-	1	1	1
 い	-	0	0	1
 い	*	1	1	0
 い	-	1	1	0
表2				
 名称	抽出結果			
 あ	イ=2/3,ハ=1/2			
 い	イ=1/3,ロ=1/3,ハ=0/2			

条件)
・表1はD列以降にあり、表2はA,B列を使用
・同一名称の中で、イ、ロ、ハの各合計が「0」以上が対象で、印「*」があるものの合計と共に表示する
表示例:「あ」の場合
・イは「3」あり「*」付きは「2」、ロは「0」、ハは「2」あり「*」付きは「1」
・表示は「=」と「/」「,」を使用して「イ=2/3,ハ=1/2」とする
補足)
・表1は1万行程度、最大2万行まで(都度変わります)
・イ、ロ..は30種類まで
・表2の名称は、予め作成済み

類似の件名で教えていただいたことがあるのですが、自力では応用ができません。
よろしくお願いいたします。

< 使用 Excel:Excel2010、使用 OS:Windows7 >


 B2 =SUBSTITUTE(TRIM(REPT("イ="&COUNTIFS(C$2:C$10,A2,D$2:D$10,"~*",E$2:E$10,1)&"/"&COUNTIFS(C$2:C$10,A2,E$2:E$10,1),COUNTIFS(C$2:C$10,A2,D$2:D$10,"~*",E$2:E$10,1)>0)&" "&REPT("ロ="&COUNTIFS(C$2:C$10,A2,D$2:D$10,"~*",F$2:F$10,1)&"/"&COUNTIFS(C$2:C$10,A2,F$2:F$10,1),COUNTIFS(C$2:C$10,A2,F$2:F$10,1)>0)&" "&REPT("ハ="&COUNTIFS(C$2:C$10,A2,D$2:D$10,"~*",G$2:G$10,1)&"/"&COUNTIFS(C$2:C$10,A2,G$2:G$10,1),COUNTIFS(C$2:C$10,A2,G$2:G$10,1)>0))," ",",")

(GobGob) 2014/09/29(月) 08:07


 >イ、ロ..は30種類まで

 ならB列で一括見たいなのは数式処理としては現実的ではないね
 VBAだね。
  

(GobGob) 2014/09/29(月) 08:10


早々にありがとうございます。 今、確認できる環境にないため返礼のみで失礼します。
う〜ん、関数式では無理っぽいですか?
作業列とIF文の組合せを考えていたんですが、作業列はともかく、やたら式も長くなり
途中でギブアップしてしまいました。
経験はないですがピポッド?とLOOKUPの組合せで効率よくできないか?..と
思ったりしましたが、これも式が長くなりそうで..

(daddy) 2014/09/29(月) 08:50


 >経験はないですがピポッド?とLOOKUPの組合せで効率よくできないか?..と 

 根本的に違うね。1セルで結果を数珠繋ぎ(?)する以上、数式が長くなるだけ。ってこと。

 だからVBAがいいんでない?ってこと。
 
(GobGob) 2014/09/29(月) 09:34

 VBA案 と言いつつ作業列をまとめただけの計算式
    Sub いろは()
        Dim Result
        Dim 行end As Long
        Dim 列end As Long
        Dim 無 As Long, 印 As Long, 名 As String
        Result = Range("A1").CurrentRegion.Resize(, 2).Value
        行end = Cells(Rows.Count, "D").End(xlUp).Row
        列end = Cells(1, Columns.Count).End(xlToLeft).Column
        For r = 2 To UBound(Result, 1)
            Result(r, 2) = ""
            For c = Range("F1").Column To 列end
                検索列 = Range(Cells(2, c), Cells(行end, c)).Address(0, 0)
                名 = Cells(1, c).Value & "="
                印 = Evaluate("SUMIFS(" & 検索列 & ",D2:D" & 行end & ",""" & Result(r, 1) & """,E2:E" & 行end & ",""~*"")")
                無 = Evaluate("SUMIFS(" & 検索列 & ",D2:D" & 行end & ",""" & Result(r, 1) & """)")
                If 印 + 無 > 0 Then
                    Result(r, 2) = Result(r, 2) & 名 & 印 & "/" & 無 & ","
                End If
            Next c
            Result(r, 2) = Left(Result(r, 2), Len(Result(r, 2)) - 1)
        Next r
        Range("A1").Resize(UBound(Result, 1), UBound(Result, 2)).Value = Result
    End Sub

(稲葉) 2014/09/29(月) 10:39


スミマセン、確認遅くなりました。

GobGobさん、>根本的に違うね..(略)

納得です _ _;、GobGobさんにいわれるとほぼあきらめがつきます(苦笑)

稲葉さん、例示ではうまくできました!

実データでは >Result(r, 2) = Left(Result(r, 2), Len(Result(r, 2)) - 1)< で「プロシージャの呼び出し、または引数が不正」になります。

A列(名称)の文字種、字数に制限があるのでしょうか?

因みに、「全半角のカタカナ、英数字、漢字かな、記号」に対応したいです。
字数は..半角で20までのようです。

ネットで調べると“よくあるエラー”(使用側の)らしいので、もっと調べてはみます..

(daddy) 2014/09/30(火) 23:10


 >       Result = Range("A1").CurrentRegion.Resize(, 2).Value
 >       行end = Cells(Rows.Count, "D").End(xlUp).Row
 >       列end = Cells(1, Columns.Count).End(xlToLeft).Column

 この3行は自分で実際の表範囲に合わせてくださいね。
 A1とDとCells(1の1
( 稲葉) 2014/10/01(水) 07:19

ありがとうございます。

 >この3行は自分で実際の表範囲に合わせてくださいね。A1とDとCells(1の1

1行目はタイトル行で2行目からデータがあるので、それぞれ「A2」「Cells(2」に
すればいいんですね? お恥ずかしい内容でスミマセン..

帰宅後に確認します..

(daddy) 2014/10/01(水) 09:29


 つかぬことをお聞きしますが、、

 「名称」は一塊になっているのですか?
 それともずーっと後の方でまた「あ」が出現したりするのですか?

(半平太) 2014/10/01(水) 20:04


ありがとうございます。

稲葉さん
修正して実行しましたが、前回と同じ箇所で同じエラ−メッセージが出ました???

 >行end = Cells(Rows.Count, "D").End(xlUp).Row →これはそのままですが、どういう時に修正が必要でしょうか?

半平太さん
名称は一塊になっています。

(daddy) 2014/10/01(水) 22:54


 こちらは自身のシートでできているので、どこかが違うんでしょうね。
 セル番地と実データ載せてください。

( 稲葉) 2014/10/01(水) 23:54


 >名称は一塊になっています。 

 ありがとうございます。

 一緒にお聞きすればよかったのですけど、以下はどうですか?
  (1)表1のイ、ロ、・・・列に入っているデータは、1と0だけですか?(2とか空白とかもありますか)
  (2)表2の「名称」の想定最大行数

(半平太) 2014/10/02(木) 07:08


ありがとうございます。 

稲葉さん、実データ確認できるまで少々お時間ください..事前知識として、
・「行end = Cells(Rows.Count, "D").End(xlUp).Row」の「D」は実データがD列
 以降にあれば変更する必要はないですよね?
 また、30列までであればOKですよね?
・仮にイ、ロ、..列に数値以外があると件のエラー表示になりますか?
 (一応、IFERRORで回避しているつもりなんですが..)
・タイトル行(1行目)の項目名(名称、印、イ、ロなど)に制限ありますか?
 (例示とは異なりますがよろしいでしょうか?)

半平太さん、以下補足と回答になります。
・D列(名称)は、元データはバラバラですが「昇順で並べ替え」しています
・イ、ロ、..列に入っているデータは、「1と0」だけではありません。数値です
 (..の筈なんですが、これも見直します(汗))
・表2の「名称」の想定最大行数⇒二千行までに収まると考えています

ちょっと逸れますが、表1を元にC列に新たに出力したい内容があるのですが
(これも自力でするつもりがギブアップです..涙)、別モノとして新たに掲示
した方がよろしいでしょうか?

(daddy) 2014/10/02(木) 09:20


 >「プロシージャの呼び出し、または引数が不正」になります。 
 稲葉さんのコードは、 
  Result = Range("A1").CurrentRegion.Resize(, 2).Value
 としているので、もしC1セルにタイトルでも入っているとD列とも地続きになるので、
 抽出対象行がD列の最終行に延長されて、そのトラブルになっちゃいます。

 あと、10,000*30もあるデータだと時間が相当かかります。
 ※私の非力なPCだと応答なしに陥ります。

 データのあるシートをアクティブにして、下記マクロを実行

 Sub sumByNameAndColumn()
    Const 閾値Address = "AA1" '←閾値が入っているアドレスを指定する
    Dim 閾値
    Dim tblNameIn              '名称列を1行余分に取り込む
    Dim tbl印
    Dim tblVal                  '数値データ
    Dim tblNameOut              '検索用名称列
    Dim tblResult()             '結果表示用列
    Dim NN  As Long, MM As Long, JJ As Long
    Dim numOfFactors As Long
    Dim nameToSkip
    Dim kei() As Double
    Dim keiOnStar() As Double
    Dim first_Last              '名称別「先頭行-最終行」
    Dim strResult(1 To 2)       '合成文字列の横2セル分を格納
    Dim dic As Object

    閾値 = Range(閾値Address).Value
    If IsEmpty(閾値) Then
        MsgBox 閾値Address & "セルに閾値を入力してから開始してください"
        Exit Sub
    End If

    Range("B2:C5000").ClearContents
    tblNameOut = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Value

    Set dic = CreateObject("Scripting.Dictionary")
    For NN = 1 To UBound(tblNameOut)
        dic.Item(tblNameOut(NN, 1)) = NN
    Next

    tblResult = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 1).Resize(, 2).Value

    tblNameIn = Range("D1", Cells(Rows.Count, "D").End(xlUp).Offset(1)).Value
    tbl印 = Range("E1").Resize(UBound(tblNameIn)).Value

    numOfFactors = Application.Min(Range(閾値Address).Column - 1, Cells(1, "F").End(xlToRight).Column) - 5

    tblVal = Range("F1").Resize(UBound(tblNameIn), numOfFactors).Value

    ReDim kei(1 To numOfFactors)
    ReDim keiOnStar(1 To numOfFactors)
    nameToSkip = Empty

    For NN = 2 To UBound(tblNameIn) - 1                     'データ名称を順次チェック
        If nameToSkip <> tblNameIn(NN, 1) Then              '処理対象の名称(SKIP出来ない)
            If tblNameIn(NN, 1) <> tblNameIn(NN - 1, 1) Then '個別名称開始行
                Rem 抽出対象の名称かチェック
                If dic.Exists(tblNameIn(NN, 1)) Then             '抽出対象に存在する
                    tblResult(dic.Item(tblNameIn(NN, 1)), 1) = Format(NN, "00000-") '個別始行を記録
                Else
                    nameToSkip = tblNameIn(NN, 1) '処理対象外の名称をメモする
                End If
            End If
         End If

        If nameToSkip <> tblNameIn(NN, 1) Then                 '処理対象の名称(SKIP出来ない)
            If tblNameIn(NN, 1) <> tblNameIn(NN + 1, 1) Then   '個別名称の最終行である
                tblResult(dic.Item(tblNameIn(NN, 1)), 1) = _
                tblResult(dic.Item(tblNameIn(NN, 1)), 1) & Format(NN, "00000") '最終行を記録
            End If
        End If
    Next NN

    For NN = 1 To UBound(tblResult)      '上記調査の結果、開始-終了行データだけあぶり出す
        first_Last = tblResult(NN, 1)
        If tblResult(NN, 1) <> Empty Then

            ReDim kei(1 To numOfFactors)
            ReDim keiOnStar(1 To numOfFactors)

            For MM = Left(first_Last, 5) To Right(first_Last, 5)
                For JJ = 1 To numOfFactors
                    kei(JJ) = kei(JJ) + tblVal(MM, JJ)  '*印と関係なく合算
                Next JJ

                If tbl印(MM, 1) = "*" Then   '*印がある行だけ合算
                    For JJ = 1 To numOfFactors
                        keiOnStar(JJ) = keiOnStar(JJ) + tblVal(MM, JJ)
                    Next JJ
                End If
            Next MM

            Erase strResult  '合成文字列の横2セル分を初期化

            For MM = 1 To numOfFactors
                If kei(MM) <> 0 Then
                    strResult(1) = strResult(1) & IIf(Len(strResult(1)), ",", "") & _
                        tblVal(1, MM) & "=" & keiOnStar(MM) & "/" & kei(MM)

                    If keiOnStar(MM) / kei(MM) >= 閾値 Then
                        strResult(2) = strResult(2) & IIf(Len(strResult(2)), ",", "") & _
                        tblVal(1, MM)
                    End If
                End If
            Next MM

            tblResult(NN, 1) = strResult(1)  '開始-終了データを合成文字列で置き換える

            If IsEmpty(strResult(2)) Then   '閾値以上の処理
                 tblResult(NN, 2) = "-"
            Else
                 tblResult(NN, 2) = strResult(2)
            End If
        End If
    Next NN
    Range("B2").Resize(UBound(tblResult), 2).Value = tblResult 'シートに書き出し
End Sub

(半平太) 2014/10/02(木) 20:05 →2014/10/6 11:55 全面書き換え


 乗りかかった船頭ですが、うまく導けそうにないので降ります。
 10000行あると、Evalute繰り返すと時間かかりますし・・・

 半平太さん、ありがとうございました。
(稲葉) 2014/10/03(金) 08:45

確認遅くなり申訳ないです。
実データ処理の方に問題があり、時間を費やしてしまいました。

半平太さん、実データ問題なく処理できましたっ!
処理時間も全く問題ありません。
(確認は6千行程度のデータですが、体感的には“アッ”という間です^^;)

で、C列での追加処理内容を取りあえず記載させていただきます。
別で掲示アップすべきであれば、ご指摘ください。
追加処理)
★イ、ロ、..で「合計比」が閾値以上に該当する場合は、C列に表示する
閾値が「1/2」の場合、例示では下記(抽出2)としたいです。
(非該当は「-」表示)

 名称	抽出	                抽出2
 あ	イ=2/3,ハ=1/2	        イ,ハ
 い	イ=1/3,ロ=1/3,ハ=0/2	-

また、閾値は「AA1セル」(セルは将来変えられるようにしたいです)に入力済みとします。
マクロであれば、今回のに追加でも、今回とは別でも構いません。

勝手いいますが、よろしくお願いします。

(daddy) 2014/10/05(日) 11:26


 >また、閾値は「AA1セル」(セルは将来変えられるようにしたいです)に入力済みとします。

 うーむ、1行目はタイトルが書かれるところで、
 イ、ロ、ハ、・・は、30種まで有るとのお話だったと思うのですけど。。

 仮りの話しとは云え、矛盾の無い前提にしてください。

(半平太) 2014/10/05(日) 19:28


ごもっともです。 スミマセン..

「30種類」は想定で、今のところ「20」までに収まっているため「AA1」との表現になりました。
ただ、臨機応変に対応したく(セルは将来変えられるようにしたいです)ということでした。

説明足らず申訳ありません。

「閾値のセル」はある意味どこでも(別シートでも)構いません。
ただ、「可変」にしたいです。←閾値のことです(2014/10/06 追記)
よって、式なりマクロなり「変更箇所を提示」いただければOKです。

勝手ばかりですが、よろしくお願いします。

(daddy) 2014/10/05(日) 23:20


 種類の数も可変です。
 いまは20の種類かもしれませんが、これは順次増えていきますよね?

 その延長上に閾値を配置する、と云う構想は危ういです。

 30種までと決まっていれば、それより右なら危なくもないですが、
 本当にそんな前提で進めていいものなのか?

 ここで回答側の反応は分かれます。
 (1)もっと安全な展開に持って行く(常識型−多数派)
 (2)自身が決めた仕様に責任を持ってもらう(自己責任型-少数派)

 下手に気を利かすと余計なお世話になることもあるので、私は少数派です。

 [前提]
 1.一行目は種類の右方向に(隣接しているか、離れているかは問わない)
   閾値(数値)が一つ入力されているレイアウトであるものとします。

 2.閾値が入力されているセルアドレスはプログラムの一行目で指定するものとします。

 >「変更箇所を提示」いただければOKです。 
 そう単純でもないのですけど、似たようなものには違いありません。
 そんな代物をまた載せるのもスペースの無駄ですので、
 (2014/10/02(木) 20:05)のコードを上書きしておきましたのでそれをコピペしてください。

(半平太) 2014/10/06(月) 11:58


何度もお手数かけました、 実データでうまくいきましたっ!

 >下手に気を利かすと余計なお世話になることもあるので、私は少数派です。
 > [前提]
 > 1.一行目は種類の右方向に(隣接しているか、離れているかは問わない)
 >   閾値(数値)が一つ入力されているレイアウトであるものとします。
 >2.閾値が入力されているセルアドレスはプログラムの一行目で指定するものとします。

⇒全く問題ありません。

最初からキチンと説明すればいいものを、余計な心遣いをさせてしまい申訳ありません。
(GobGobさん、稲葉さんにも説明ベタお詫びします _ _;)

う〜ん、「スゴイっ!」の一言ですね..
エクセルでできる“可能性”と半平太さんに“しびれ”ました..(本当です)

些細な領域になりますが、B列が「空欄(非該当?)」の時にC列に「-」と「空欄」があります。なぜでしょうか?
実害はなさそうなので、これとB列の「非該当」も「-」表示にする..というのは自分への「宿題」にしようと思っています。

注釈をつけていただいているので何をしようとされているかフローはおおよそわかりますので、
教科書としてマクロの理解に努めたいと思っています。

オツムの血のめぐりが悪いので時間がかかりそうですが、新たな質問なんぞはこのまま続けていってもいいもんでしょうか?
ある程度時間経ったものは“抜き書き”して新規に掲示アップした方がいいんですかね?

これからもよろしくお願いします。

(daddy) 2014/10/06(月) 22:50


 >何をしようとされているかフローはおおよそわかります

 方針:不要な計算はしない

 フロー
 1.事前準備として、A列の名称をKeyにDicrionaryに登録する。
   保持する値はA列の行番号(ただし1だけ小さい。A2セルが1に該当)

 2.D列の名称を順次読み込んで、それが集計対象なのか判断する。
   集計対象かどうかは、Dicrionaryに存在するかどうかで判定する。
   Match関数でも判定は出来るが、Dictionaryの方が段違いに速い。

 3.Dictionaryにない名称は、計算する必要がないのでSkipする。
   計算を要する名称は、開始行番と最終行番を00000-00000の形で結果表示配列内にメモる。

 4.上記調査の結果、結果配列内に00000-00000のメモがあるものについて、
   データテーブル内の当該開始行番から最終行番までを集計し、
   その結果を所期の文字列にアレンジして、00000-00000の情報と置換えて行く。

 >些細な領域になりますが、B列が「空欄(非該当?)」の時にC列に「-」と「空欄」があります。なぜでしょうか? 

 非該当と目されるデータには2種類あります。
 (1)上記4における「00000-00000」のデータがないもの。これは処理自体が何も行われないので「空欄」となる。
 (2)「00000-00000」のデータがあって処理はしたものの、集計結果が表示すべきレベルに至らなかったもの。
   これには「処理」の最終段階で「-」が入れられる。

 >実害はなさそうなので、これとB列の「非該当」も「-」表示にする..というのは自分への「宿題」にしようと思っています。 
 との事なので、私はノータッチとします。

 >新たな質問なんぞはこのまま続けていってもいいもんでしょうか? 
 >ある程度時間経ったものは“抜き書き”して新規に掲示アップした方がいいんですかね? 
 内容によります。掲示したコードに直接関係あったり、僅かな修正の話なら、1年後でもここで構いません。
 データだけは同じだが、今回の処理とは大幅に変わる話なら、新規で立ててください。

(半平太) 2014/10/07(火) 09:36


ご説明ありがとうございます。 
ほとんど何もわかっていなかったことがよくわかりました(苦笑)

「何をしようとされているかフローはおおよそわかります..」
などという“思い上がった”文章は“撤回”させてください(汗)

>方針:不要な計算はしない<
きっとこれが処理速度に大きく貢献をしているんでしょうね..
(全くストレスを感じませんから..)
やたら“重い”ブックを複数持ってますので、別の機会に相談させて
いただこうかと思っています。

提示いただいたマクロに関しての質問は、お言葉に甘えて本欄にて
させていただきます。

みなさんに出会えてよかったです、これからもよろしくお願いします。 

(daddy) 2014/10/07(火) 13:25


半平太さん、お世話になります。

中坊(中学生)のころ、初めて習う英語で一所懸命“単語”を
調べていたのを懐かしく想い出しつつ、提示いただいたマクロを
理解しようとしてますが...下記教えていただけますでしょうか?

・D列を「1行余分に取り込む」のはなぜでしょうか?
 最終行の確認に必要なのでは?と思いましたがよくわかりません..

・自ら宣言した“宿題”については白旗を揚げざるを得ないですが(涙)、
 これを実現しようとすると処理時間に悪影響を与えそうに思いますが、
 どうでしょうか?−“何となく思う”だけなのでご見解を伺いたく..
(「悪影響」とは今より“遅くなった”と体感できるレベルをいいます)

現在、まだ1万行程度しか実績ないですが、快適です(笑)
※現在は strResult(2) のif文に And で条件追加して使用しています
また、今までに作成した処理を含めいろいろと改善や応用ができそうで楽しみです。

これからもよろしくお願いします。

(daddy) 2014/10/15(水) 12:03


 >・D列を「1行余分に取り込む」のはなぜでしょうか? 
 >  最終行の確認に必要なのでは?と思いました

 その通りです。
 名称が一塊になっているのを利用して、各名称の最終行番を取得する際、
 次の行の名称と同じであるかチェックしているのですけど、
 最終データだけは、そのロジックを適用すると次の行が存在しないので
 トラブっちゃう為です。

 >・自ら宣言した“宿題”については白旗を揚げざるを得ないですが(涙)、 
 >  これを実現しようとすると処理時間に悪影響を与えそうに思いますが、 
 >  どうでしょうか?−“何となく思う”だけなのでご見解を伺いたく.. 
 > (「悪影響」とは今より“遅くなった”と体感できるレベルをいいます) 

 どうなんでしょうね?
 やってみないと分かりませんが、体感的には微差だと思います。

 >    For NN = 1 To UBound(tblResult)      '上記調査の結果、開始-終了行データだけあぶり出す
 >        first_Last = tblResult(NN, 1)
 >        If tblResult(NN, 1) <> Empty Then

 上の最後の一文を下記3文に変えるだけだと思います。
     For NN = 1 To UBound(tblResult)      '上記調査の結果、開始-終了行データだけあぶり出す
         first_Last = tblResult(NN, 1)
         If tblResult(NN, 1) = Empty Then  ’←変更
              tblResult(NN, 2) = "-"     ’←追加
         Else                ’←追加

 処理時間はともかく、以上の修正で結果がおかしくなる場合は、
 要求された仕様を私が理解していないためです。
 (つまり、単にC列に「-」が出ればいいと理解しております)

(半平太) 2014/10/15(水) 13:33


早々にありがとうございます。 スッキリしました..
さりげなく“最初の”宿題の「答え」までいただき感謝します(笑)

懲りずにまた説明足らずしちゃいましたが、“最初の”は
>単にC列に「-」が出ればいいと理解< でまちがいありませんが、
時間を気にしていたのは“B列の「非該当」も「-」表示にする” 
の方でした。 方法がわからない故にせっかく、
>Dictionaryにない名称は、計算する必要がないのでSkip<
しているのに、なんだか余計なことをして時間ロスしそうで..

こちらも「If tblResult(NN, 1) = Empty Then」の後に「tblResult(NN, 1) = "-"」          
を追加すればいいんですよね?(例示ではうまくいきました)

この追加でよければ、仰られるように「微差」で済むような気がします。

遅くなりそうですが、実データで確認するようにします..

(daddy) 2014/10/15(水) 16:56


 >こちらも「If tblResult(NN, 1) = Empty Then」の後に「tblResult(NN, 1) = "-"」           
 >を追加すればいいんですよね?(例示ではうまくいきました) 

 仰る通りです。

(半平太) 2014/10/15(水) 17:08


恐縮です、書いた文章を訂正しようとしてた矢先に返信いただきまして..
非該当の定義をウッカりしてました(汗)

追加したB列処理方法では抽出の対象外の場合はOKですが、
抽出対象でありながら該当しない場合は「空欄」のままですよね..
(イ、ロ、..が全て「0」の場合です)

改めて整理しますと、B,C列共に
・抽出対象外(A列にD列名称がない場合)は「-」にする
・抽出対象で計算の結果、「該当なし」は「/」にする
が、理想となりましょうか。

今回ヒントをいただけたので、もう少し考えてみます。

添削あるいは「SOS」の時はお助けいただけますか?

(daddy) 2014/10/15(水) 18:15


 >改めて整理しますと、B,C列共に 
 > ・抽出対象外(A列にD列名称がない場合)は「-」にする 
 > ・抽出対象で計算の結果、「該当なし」は「/」にする 
 > が、理想となりましょうか。 

 ちょっとロジックを組み替えます。
 ※先頭行番と最終行番のセットを書出す無駄を廃止し、
  個別最終行番が判明した時点で都度個別集計を実行します

 フロー
  1-1.不変
    事前準備として、A列の名称をKeyにDicrionaryに登録する。
    保持する値はA列の行番号(ただし1だけ小さい。A2セルが1に該当)

  1-2. 結果配列には全て「-」で埋めて置く。
    この後の処理で書き込むべき文字列があると判明したものは、
    その文字列と入れ替える。

  2.不変
    D列の名称を順次読み込んで、それが集計対象なのか判断する。
    集計対象かどうかは、Dicrionaryに存在するかどうかで判定する。
    Match関数でも判定は出来るが、Dictionaryの方が段違いに速い。

  3.Dictionaryにない名称は、計算する必要がないのでSkipする。
    計算が必要な時は、開始行番と最終行番が判明次第、当該名称について集計して、
    所期の文字列を作成後、結果配列の初期値「-」と入換える。

 Sub sumByNameAndColumn()
     Const 閾値Address = "AA1" '←閾値が入っているアドレスを指定する
     Dim 閾値
     Dim tblNameIn              '名称列を1行余分に取り込む
     Dim tbl印
     Dim tblVal                  '数値データ
     Dim tblNameOut              '検索用名称列
     Dim tblResult()             '結果表示用列
     Dim posOfResult As Long     '結果表示用配列の行番号

     Dim NN  As Long, MM As Long, JJ As Long
     Dim numOfFactors As Long    'イロハの種類数
     Dim nameToSkip              '計算対象にしない名称(A列にない名称)
     Dim kei() As Double
     Dim keiOnStar() As Double
     Dim strResult(1 To 2)       '合成文字列の横2セル分を格納
     Dim dic As Object

     Dim rowStToCalc As Long     '計算開始位置
     Dim rowEdToCalc As Long     '計算終了位置

     閾値 = Range(閾値Address).Value
     If IsEmpty(閾値) Then
         MsgBox 閾値Address & "セルに閾値を入力してから開始してください"
         Exit Sub
     End If

     Range("B2:C5000").ClearContents
     tblNameOut = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Value

     Set dic = CreateObject("Scripting.Dictionary")
     For NN = 1 To UBound(tblNameOut)
         dic.Item(tblNameOut(NN, 1)) = NN 'A列内の名称をKeyに行番号を記録する(ただし1小さい)
     Next

     Rem 結果吐き出し用のテーブル(B,C列の2列に相当)、予め「-」をセットして置く
     With Range("A2", Cells(Rows.Count, "A").End(xlUp)).Offset(, 1).Resize(, 2)
         .Value = "-"
         tblResult = .Value
     End With

     tblNameIn = Range("D1", Cells(Rows.Count, "D").End(xlUp).Offset(1)).Value
     tbl印 = Range("E1").Resize(UBound(tblNameIn)).Value

     numOfFactors = Application.Min(Range(閾値Address).Column - 1, Cells(1, "F") _
                                                                 .End(xlToRight).Column) - 5

     tblVal = Range("F1").Resize(UBound(tblNameIn), numOfFactors).Value

     ReDim kei(1 To numOfFactors)
     ReDim keiOnStar(1 To numOfFactors)
     nameToSkip = Empty

     For NN = 2 To UBound(tblNameIn) - 1                         'D列の名称を順次チェック
         If nameToSkip <> tblNameIn(NN, 1) Then                  '処理対象の名称(SKIP出来ない)
             If tblNameIn(NN, 1) <> tblNameIn(NN - 1, 1) Then    '個別名称開始行
                 Rem 抽出対象の名称かチェック
                 If dic.Exists(tblNameIn(NN, 1)) Then            'A列に存在する名称である
                     rowStToCalc = NN                            '個別計算始行を格納
                     posOfResult = dic.Item(tblNameIn(NN, 1))     'A列内名称の行番号を格納
                 Else
                     nameToSkip = tblNameIn(NN, 1)               '処理対象外の名称をメモする
                 End If
             End If
          End If

         If nameToSkip <> tblNameIn(NN, 1) Then                 '処理対象の名称(SKIP出来ない)
             If tblNameIn(NN, 1) <> tblNameIn(NN + 1, 1) Then   '個別名称の最終行である
                 rowEdToCalc = NN                               '個別計算末行を格納

                 Rem 個別名称の集計開始-----------------------------

                 ReDim kei(1 To numOfFactors)
                 ReDim keiOnStar(1 To numOfFactors)

                 For MM = rowStToCalc To rowEdToCalc
                     For JJ = 1 To numOfFactors
                         kei(JJ) = kei(JJ) + tblVal(MM, JJ)  '*印と関係なく合算
                     Next JJ

                     If tbl印(MM, 1) = "*" Then   '*印がある行だけ合算
                         For JJ = 1 To numOfFactors
                             keiOnStar(JJ) = keiOnStar(JJ) + tblVal(MM, JJ)
                         Next JJ
                     End If
                 Next MM

                 Erase strResult  '合成文字列の横2セル分を初期化

                 For MM = 1 To numOfFactors
                     If kei(MM) <> 0 Then
                         strResult(1) = strResult(1) & IIf(Len(strResult(1)), ",", "") & _
                             tblVal(1, MM) & "=" & keiOnStar(MM) & "/" & kei(MM)

                         If keiOnStar(MM) / kei(MM) >= 閾値 Then
                             strResult(2) = strResult(2) & IIf(Len(strResult(2)), ",", "") & _
                             tblVal(1, MM)
                         End If
                     End If
                 Next MM

                 tblResult(posOfResult, 1) = IIf(IsEmpty(strResult(1)), "/", strResult(1)) 'B列用文字を処理
                 tblResult(posOfResult, 2) = IIf(IsEmpty(strResult(2)), "/", strResult(2)) 'C列用文字を処理

                 Rem 個別名称の集計終了-----------------------------

             End If
         End If
     Next NN

     Range("B2").Resize(UBound(tblResult), 2).Value = tblResult 'シートに書き出し
 End Sub

(半平太) 2014/10/15(水) 20:02


自力ではムリなことを配慮いただき、ありがとうございます(苦笑)

先のC列への「-」表示で追加いただいたコードはそのままに、最後の方で
「/」表示するコードを足せば..ぐらいに思ってました。
(具体的なコードを思い付いたわけではないですが.._ _;)

>ちょっとロジックを組み替え< る必要性は、そんなに単純にはいかない
ということでしょうか? あるいは処理時間の為でしょうか?

例示ではうまくいきましたので、追って実データにて確認させていただきます。

(daddy) 2014/10/16(木) 13:48


 >先のC列への「-」表示で追加いただいたコードはそのままに、最後の方で 
 >「/」表示するコードを足せば..ぐらいに思ってました。 
 多分、それでいいと思います。

 >>ちょっとロジックを組み替え< る必要性は、そんなに単純にはいかない 
 > ということでしょうか? あるいは処理時間の為でしょうか? 
 多分、単純ですし、処理時間は大差ないです。

 変えたい気分になったのは諸々ですね。
 1.先頭行番と最終行番のセットを書出すフローが以前から冗長に思えていたこと。
   それを書き出すタイミングで個別集計してしまえば良かったとの後悔があります。

 2.仕様を完全に理解していないので、分かっている範囲で無難に処理したかったこと。
   以前こんなやり取りがありました。
   >>実害はなさそうなので、これとB列の「非該当」も「-」表示にする..というのは自分への「宿題」にしようと思っています。 
   >との事なので、私はノータッチとします。
   私がノータッチにしたのは、仕様を再確認する面倒を避けたかったからです。
     分かり切っている様でもしっかり確認しなかった為に、回答側の早合点になってしまった例はままあります。
   回答側が大変に思うことは、解決策を考えることではなく、質問の意味を正確に理解することであると云ってもいい位です。

 3.部分的な増改築を繰り返すとプログラムが汚らしくなっていくこと。
   (初めから○○が分かっていたら、今の作りにはしない、と云うものに成り下がって行くこと)

(半平太) 2014/10/16(木) 15:16


ありがとうございます。
実データでも処理時間含め問題ありませんでした。

いただいたコメント、承知いたしました..納得です。

やはり“プロ”ですね、半平太さんは。
(SEとか職業のことではなく、“ハート”がです)

こちらもキチンと説明できるように以後気をつけます。
(なんだか以前にも書いたような..なかなか直りませんね、説明ベタ.._ _;)

これからもよろしくお願いします。

(daddy) 2014/10/17(金) 07:51


お世話になります。

提示いただいたマクロでお教えください。
中ほどで下記のコードが2回出てきますが、それぞれどのような
意味があるのでしょうか?
>ReDim kei(1 To numOfFactors)
>ReDim keiOnStar(1 To numOfFactors)

現在、印の種類を増やしたりIf分を追加修正したりして他への応用展開をしています。
実績?として、これまで関数式で数回に分けて行っていた処理が1回で済んだ例があり、
とても重宝しています。
が、如何せん、マクロの知識がまだまだ乏しく意味もわからずに“切った貼った”を
しているにすぎません..(涙)
いじったコードは事前確認はしているものの数千行のデータを逐一確認できるわけもなく、
正直、非常に不安です。(苦笑)
で、“自習”していて???と思ったのが上記となります。
(他はまだ“わからない”のがわからない状態だと思います)

よろしくお願いします。

(daddy) 2014/10/24(金) 15:12


 >    ReDim kei(1 To numOfFactors)
 >    ReDim keiOnStar(1 To numOfFactors)
 >    nameToSkip = Empty

 この3行ですね。

 何か事を始める前に、使い回しされる変数の初期化をしております。
 その方が安心なので。。
 必要ないと云えば必要ないです。

 daddyさんのお好みで処理してください。

(半平太) 2014/10/24(金) 16:31


>何か事を始める前に、使い回しされる変数の初期化をして(略)その方が安心

ありがとうございます。 心がけるようにします。

今日、2つ目の応用マクロを作成して簡単な確認作業を終わったところです。
結構自信はあるのですが、実データではどうなりますことやら..

これからもよろしくお願いします。

(daddy) 2014/10/25(土) 18:18


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.