コンピュータは働きたくて、いつもウズウズしています!   Data + Automation = Datamation
TEXT_SIZE

101 行列合算プログラム

この行列合算プログラムは、データ行列において、行と行の合算や列と列の合算をする時に使用します。
なおこのプログラムに限り、ソースを公開します。

サンプルデータ

101 行列合算プログラム サンプルデータ

このデータ行列で、a1列とa5列、b1行とb7行を合算した時の行列は、次のようになります。
簡単な場合は暗算でできますが、データ行列が大きい場合や、合算する列や行が多くなると面倒になってきます。


操作手順

アドイン接続した後、メニューの「行列合算」をクリックすると、次の設定画面が表示されます。

101 行列合算プログラム 設定画面

「データの範囲」は、上の表の水色で塗りつぶした部分をマウスでドラッグして範囲選択します。

データラベルを含めて範囲選択した場合は、 「行と列のラベル」の「共にあり」をクリックして選択します。

「合算する列の指定」では、列ラベル(ここでは2行目のa1~a5と書かれたセル)のみをクリックして選択します。
複数列を選択する場合は、[Ctrl]キーで選択するのではなく、画面で指定されているようにします。
簡単な方法は、まずは[Ctrl]キーで選択したあとに、自動的に付与される区切りの「カンマ記号」を削除します。

「合算する行の指定」では、行ラベル(ここではB列のb1~b7と書かれたセル)のみをクリックして選択します。
複数列を選択する場合は、[Ctrl]キーで選択するのではなく、画面で指定されているようにします。
簡単な方法は、まずは[Ctrl]キーで選択したあとに、自動的に付与される区切りの「カンマ記号」を削除します。

「出力先」では、出力を開始したいセル1か所をクリックして選択します。

設定が済んだら、「開始」ボタンをクリックします。
ここで設定画面を閉じるには、「中止」ボタンをクリックします。


出力結果

101 行列合算プログラム 出力結果


参考

本プログラムでは、最も簡単で単純な方法として、配列A(I,j)とB(I,j)を用意します。

まず、データ行列を配列A(I,j)に読込みます。
結果を次のように配列B(I,j)に格納します。

  B(I,1)=A(I,1)
  B(I,2)=A(I,2)
  B(I,3)=A(I,3)+A(I,7)+A(I,10)
  B(I,4)=A(I,4)
  B(I,5)=A(I,5)
  B(I,6)=A(I,6)
  B(I,7)=A(I,8)
  B(I,8)=A(I,9)
  B(I,9)=A(I,11) ここで、I=1から19までです

同様にして、次のように行の合算を行います。

  A(1,j)=B(1,j)
  A(2,j)=B(2,j)
  A(3,j)=B(3,j)+B(8,j)+B(17,j)+B(18,j)
  A(4,j)=B(4,j)、 A(5,j)=B(5,j)、 A(6,j)=B(6,j)、 A(7,j)=B(7,j)、 A(8,j)=B(9,j)、
  A(9,j)=B(10,j)、 A(10,j)=B(11,j)、 A(11,j)=B(12,j)、 A(12,j)=B(13,j)、 A(13,j)=B(14,j)、
  A(14,j)=B(15,j)、 A(15,j)=B(16,j)、A(16,j)=B(19,j) ここで、J=1から9までです。

最後に、ラベルを結果行列のように編集し、出力します。

なおこのプログラムでは、400行x100列の大きさのデータ行列の合算が自由にできるようにしています。
更に大きいデータ行列を取り扱う場合は、下記のように公開しているソースコードから、配列の大きさに関する部分を変更することで、簡単に実現できます。


無料配布中。リクエスト・フォームへ行く


▼動作環境・アドイン接続方法へ▼


フォームのソースコード……本プログラムのみ、ソースコードを無償で公開しております。

Private Sub CommandButton1_Click()
'YES
Module1.DATA_IN
End Sub
Private Sub CommandButton2_Click()
'No
End
End Sub


モジュールのソースコード……本プログラムのみ、ソースコードを無償で公開しております。

Option Explicit

Sub Mtr_addMain()
'********************************************************************
'***  行列合算メイン
'********************************************************************
    UserForm1.Show
End Sub

Function DATA_IN() As Integer
'********************************************************************
'***  Userformからの選択範囲の読込処理
'********************************************************************
Dim out, din As Range
Dim dataadd1 As String
Dim datasheet1 As String
Dim startcell1 As String
Dim rowm As Integer
Dim coln As Integer
Dim dataadd2 As String
Dim datasheet2 As String
Dim dhan2(100) As String
Dim cnt2 As Integer
Dim dataadd3 As String
Dim datasheet3 As String
Dim dhan3(100) As String
Dim cnt3 As Integer
Dim dataadd4 As String
Dim datasheet4 As String
Dim startcell4 As String
Dim AA(400, 100) As Double
Dim CA(100) As String
Dim RA(400) As String
Dim CR As String
Dim rhan(100) As Integer
Dim chan(100) As Integer
Dim rcnt As Integer
Dim ccnt As Integer
Dim isw As Integer
Dim ksw As Integer
Dim flg As Integer
Dim flg1 As Integer
Dim flg2 As Integer
Dim flg3 As Integer
Dim iflg As Integer
Dim cnt As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
    
    On Error GoTo EEEE
    DATA_IN = 0
    dataadd1 = UserForm1.RefEdit1.Value
    If dataadd1 = "" Then
        MsgBox "データ範囲が指定されていません。"
        Exit Function
    End If
    If UserForm1.OptionButton1.Value = True Then flg1 = 1
    If UserForm1.OptionButton2.Value = True Then flg1 = 2
    If flg1 = 0 Then
        MsgBox "ラベルの有無を指定して下さい。"
        Exit Function
    End If
    iflg = DATA_IN_SNG(dataadd1, datasheet1, startcell1)
    If iflg = 999 Then GoTo EEEE
    dataadd2 = UserForm1.RefEdit2.Value
    If dataadd2 = "" Then
        flg2 = 1
    Else
        iflg = DATA_IN_STR(dataadd2, datasheet2, dhan2, cnt2)
        If iflg = 999 Then GoTo EEEE
    End If
    dataadd3 = UserForm1.RefEdit3.Value
    If dataadd3 = "" Then
        flg3 = 1
    Else
        iflg = DATA_IN_STR(dataadd3, datasheet3, dhan3, cnt3)
        If iflg = 999 Then GoTo EEEE
    End If
    dataadd4 = UserForm1.RefEdit4.Value
    If dataadd4 = "" Then
        MsgBox "出力先が指定されていません。"
        Exit Function
    End If
    iflg = DATA_IN_SNG(dataadd4, datasheet4, startcell4)
    If iflg = 999 Then GoTo EEEE
    Sheets(datasheet1).Select
    With Sheets(datasheet1)
        rowm = .Range(dataadd1).Rows.Count
        coln = .Range(dataadd1).Columns.Count
    End With
    If rowm > 400 Then
        MsgBox "行数が制限を越えています。"
        Exit Function
    End If
    If coln > 100 Then
        MsgBox "列数が制限を越えています。"
        Exit Function
    End If
    Unload UserForm1
    
    'Start
    If flg1 = 1 Then isw = 1
    If flg1 = 2 Then isw = 0
    Sheets(datasheet4).Select
    Set out = Sheets(datasheet4).Range(startcell4)
    Sheets(datasheet1).Select
    Set din = Sheets(datasheet1).Range(startcell1)
    iflg = Add_Pickup(datasheet1, startcell1, datasheet2, dhan2, cnt2, _
                        datasheet3, dhan3, cnt3, chan, rhan)
    If iflg = 999 Then GoTo EEEE
    iflg = Han_Sort(chan, cnt2)
    iflg = Han_Sort(rhan, cnt3)
    If iflg = 999 Then GoTo EEEE
    'Head_Read
    If isw = 1 Then
        CR = din.Offset(0, 0).Value
        For j = isw To coln - 1
            CA(j - 1) = din.Offset(0, j).Value
        Next j
        For i = isw To rowm - 1
            RA(i - 1) = din.Offset(i, 0)
        Next i
    End If
    'Data_Read
    For i = isw To rowm - 1
        For j = isw To coln - 1
            AA(i - isw, j - isw) = din.Offset(i, j).Value
        Next j
    Next i
    If flg2 = 0 And flg3 = 1 Then
        iflg = Add_col(rowm, coln, isw, ccnt, cnt2, chan, AA)
        If iflg = 999 Then GoTo EEEE
        ccnt = coln - cnt2 + 1
        rcnt = rowm
    End If
    If flg3 = 0 And flg2 = 1 Then
        iflg = Add_row(rowm, coln, isw, rcnt, cnt3, rhan, AA)
        If iflg = 999 Then GoTo EEEE
        ccnt = coln
        rcnt = rowm - cnt3 + 1
    End If
    If flg2 = 0 And flg3 = 0 Then
        iflg = Add_col(rowm, coln, isw, ccnt, cnt2, chan, AA)
        If iflg = 999 Then GoTo EEEE
        iflg = Add_row(rowm, coln, isw, rcnt, cnt3, rhan, AA)
        If iflg = 999 Then GoTo EEEE
    End If
    'AreaClear
    For i = 0 To rowm - 1
    For j = 0 To coln - 1
        out.Offset(i, j) = ""
    Next j
    Next i
    'Head_PRN
    If isw = 1 Then
        out.Offset(0, 0).Value = CR
        If cnt2 > 1 Then
            cnt = 1
            For j = 1 To coln - 1
                For k = 2 To cnt2
                    If j <> (chan(k) - chan(0)) Then
                        flg = 1
                    Else
                        flg = 0
                        Exit For
                    End If
                Next k
                If flg = 1 Then
                    out.Offset(0, cnt).Value = CA(j - 1)
                    cnt = cnt + 1
                End If
            Next j
            ccnt = cnt - 1
        Else
            For j = 1 To coln - 1
                out.Offset(0, j).Value = CA(j - 1)
            Next j
            ccnt = coln - 1
        End If
        If cnt3 > 1 Then
            cnt = 1
            For i = 1 To rowm - 1
                For k = 2 To cnt3
                    If i <> (rhan(k) - rhan(0)) Then
                        flg = 1
                    Else
                        flg = 0
                        Exit For
                    End If
                Next k
                If flg = 1 Then
                    out.Offset(cnt, 0).Value = RA(i - 1)
                    cnt = cnt + 1
                End If
            Next i
            rcnt = cnt - 1
        Else
            For i = 1 To rowm - 1
                out.Offset(i, 0).Value = RA(i - 1)
            Next i
            rcnt = rowm - 1
        End If
    End If
    'Ans_PRN
    For i = 0 To rcnt - 1
        For j = 0 To ccnt - 1
            out.Offset(i + isw, j + isw).Value = AA(i, j)
        Next j
    Next i
    
Exit Function
EEEE:
DATA_IN = 0
End Function

Function Han_Sort(whan As Variant, cnt As Integer) As Integer
'********************************************************************
'***   行列番号の切出し処理
'********************************************************************
Dim i, j, m As Integer

    On Error GoTo EEEE
    Han_Sort = 0
    For i = 1 To cnt - 1
    For j = i + 1 To cnt
        If whan(i) > whan(j) Then
            m = whan(i)
            whan(i) = whan(j)
            whan(j) = m
        End If
    Next j
    Next i
    
Exit Function
EEEE:
Han_Sort = 999
End Function

Function Add_Pickup(datasheet1 As String, startcell1 As String, _
                datasheet2 As String, dhan2 As Variant, cnt2 As Integer, _
                datasheet3 As String, dhan3 As Variant, cnt3 As Integer, _
                chan As Variant, rhan As Variant) As Integer
'********************************************************************
'***   行列番号の切出し処理
'********************************************************************
Dim din As Range
Dim ss As String
Dim m0, m1 As Integer
Dim i As Integer
    
    On Error GoTo EEEE
    Add_Pickup = 0
    Sheets(datasheet1).Select
    Set din = Sheets(datasheet1).Range(startcell1)
    ss = din.Offset(0, 0).Address(, , xlR1C1)
    m0 = Len(ss)
    m1 = InStr(ss, "C")
    rhan(0) = Mid(ss, 2, m1 - 2)
    chan(0) = Right(ss, m0 - m1)
    For i = 1 To cnt2
        Set din = Sheets(datasheet2).Range(dhan2(i))
        ss = din.Offset(0, 0).Address(, , xlR1C1)
        m0 = Len(ss)
        m1 = InStr(ss, "C")
        chan(i) = Right(ss, m0 - m1)
    Next i
    For i = 1 To cnt3
        Set din = Sheets(datasheet3).Range(dhan3(i))
        ss = din.Offset(0, 0).Address(, , xlR1C1)
        m0 = Len(ss)
        m1 = InStr(ss, "C")
        rhan(i) = Mid(ss, 2, m1 - 2)
    Next i
    
Exit Function
EEEE:
Add_Pickup = 999
End Function

Function Add_row(rowm As Integer, coln As Integer, isw As Integer, cnt As Integer, _
                cnt3 As Integer, rhan As Variant, AA As Variant) As Integer
'********************************************************************
'***   行番号の加算処理
'********************************************************************
Dim BB() As Double
Dim i, j, k As Integer
Dim m0, m1, flg As Integer

    On Error GoTo EEEE
    Add_row = 0
    ReDim BB(rowm, coln)
    cnt = 0
    For i = 0 To rowm - 1 - isw
        m0 = rhan(1) - rhan(0) - isw
        If m0 = i Then
            For j = 0 To coln - 1 - isw
                BB(cnt, j) = AA(m0, j)
            Next j
            For k = 2 To cnt3
                m1 = rhan(k) - rhan(0) - isw
                For j = 0 To coln - 1 - isw
                    BB(cnt, j) = BB(cnt, j) + AA(m1, j)
                Next j
            Next k
            cnt = cnt + 1
        Else
            flg = 0
            For k = 2 To cnt3
                m1 = rhan(k) - rhan(0) - isw
                If i <> m1 Then
                    flg = 1
                Else
                    flg = 0
                    Exit For
                End If
            Next k
            If flg = 1 Then
                For j = 0 To coln - 1 - isw
                    BB(cnt, j) = AA(i, j)
                Next j
                cnt = cnt + 1
            End If
        End If
    Next i
    For i = 0 To rowm
        For j = 0 To coln
            AA(i, j) = 0#
        Next j
    Next i
    For i = 0 To cnt - 1
        For j = 0 To coln - 1 - isw
            AA(i, j) = BB(i, j)
        Next j
    Next i
    
Exit Function
EEEE:
Add_row = 999
End Function

Function Add_col(rowm As Integer, coln As Integer, isw As Integer, cnt As Integer, _
                cnt2 As Integer, chan As Variant, AA As Variant) As Integer
'********************************************************************
'***   列番号の加算処理
'********************************************************************
Dim BB() As Double
Dim i, j, k As Integer
Dim m0, m1, flg As Integer

    On Error GoTo EEEE
    Add_col = 0
    ReDim BB(rowm, coln)
    cnt = 0
    For j = 0 To coln - 1 - isw
        m0 = chan(1) - chan(0) - isw
        If m0 = j Then
            For i = 0 To rowm - 1 - isw
                BB(i, cnt) = AA(i, m0)
            Next i
            For k = 2 To cnt2
                m1 = chan(k) - chan(0) - isw
                For i = 0 To rowm - 1 - isw
                    BB(i, cnt) = BB(i, cnt) + AA(i, m1)
                Next i
            Next k
            cnt = cnt + 1
        Else
            flg = 0
            For k = 2 To cnt2
                m1 = chan(k) - chan(0) - isw
                If j <> m1 Then
                    flg = 1
                Else
                    flg = 0
                    Exit For
                End If
            Next k
            If flg = 1 Then
                For i = 0 To rowm - 1 - isw
                    BB(i, cnt) = AA(i, j)
                Next i
                cnt = cnt + 1
            End If
        End If
    Next j
    For i = 0 To rowm
        For j = 0 To coln
            AA(i, j) = 0#
        Next j
    Next i
    For i = 0 To rowm - 1 - isw
        For j = 0 To cnt - 1
            AA(i, j) = BB(i, j)
        Next j
    Next i

Exit Function
EEEE:
Add_col = 999
End Function

Function DATA_IN_STR(dataadd As String, datasheet As String, _
                    datahan As Variant, kk As Integer) As Integer
'********************************************************************
'***   選択範囲の情報切出し処理
'********************************************************************
Dim cc, dd, ss As String
Dim i, k, mlen As Integer
Dim m0, m1, m2, m3, m4, m5 As Integer

    On Error GoTo EEEE
    DATA_IN_STR = 0
    datasheet = ""
    mlen = Len(dataadd)
    For i = 1 To mlen
        cc = Mid(dataadd, i, 1)
        If Not cc = "!" Then
            If cc = "'" Then
                cc = ""
            Else
                datasheet = datasheet + cc
            End If
        Else
            m0 = i
            Exit For
        End If
    Next i
    k = 1
    m1 = m0 + 1
    Do While m1 < mlen
        For i = m1 + 1 To mlen
            dd = Mid(dataadd, i, 1)
            If dd = "!" Then
                m2 = i
                m3 = m2 - m1 - m0
                ss = Mid(dataadd, m1 + 1, m3)
                m4 = Len(ss)
                m5 = InStr(ss, ":")
                ss = Left(ss, m4 - m5 + 1)
                datahan(k) = ss
                k = k + 1
                Exit For
            End If
            If i = mlen Then
                m3 = mlen - m1
                datahan(k) = Mid(dataadd, m1 + 1, m3)
                k = k + 1
                Exit Do
            End If
        Next i
        m1 = m2 + 1
    Loop
    kk = k - 1
    
Exit Function
EEEE:
DATA_IN_STR = 999
End Function

Function DATA_IN_SNG(dataadd As String, datasheet As String, _
                    startcell As String) As Integer
'********************************************************************
'***   Data Pickup from dataadd (UserForm.RefEdit.Value)
'********************************************************************
Dim cc As String
Dim i, m As Integer

    On Error GoTo EEEE
    DATA_IN_SNG = 0
    datasheet = ""
    For i = 1 To 100
        cc = Mid(dataadd, i, 1)
        If Not cc = "!" Then
            If cc = "'" Then
                cc = ""
            Else
                datasheet = datasheet + cc
            End If
        Else
            m = i
            Exit For
        End If
    Next i
    startcell = ""
    For i = m + 1 To 100
        cc = Mid(dataadd, i, 1)
        If Trim(cc) = "" Then Exit For
        If Not cc = ":" Then
            startcell = startcell + cc
        Else
            Exit For
        End If
    Next i
    
Exit Function
EEEE:
DATA_IN_SNG = 999
End Function


無料配布中。リクエスト・フォームへ行く


動作環境・アドイン接続方法

動作環境

日本語版Windows用 日本語版Microsoft Excel2003以降(推奨)が快適に動作するパソコン。
Excelのアドイン「分析ツール-VBA」のアドイン接続を必ず行い、マクロを使用可能にして下さい。
その他は、Microsoft Excelの仕様に基づきます。

なおMicrosoft社によるサポートが終了したバージョンのExcelを使用したときのいかなる障害・損害・不便などにおきましては、当方では責任を負いかねます。
予めご了承ください。

Microsoft社「Windows XP および、Office 2003 のサポート終了についてのご案内
http://www.microsoft.com/ja-jp/windows/lifecycle/sp3eos.aspx

アドイン方法

アドイン接続マニュアル Excel2003用   アドイン接続マニュアル Excel2007/2010用

get adobe_reader

商品代金 無料 (通信費などはお客様にてご負担ください。)
商品の提供方法

リクエスト・フォーム」にて入力されたメールアドレス宛に、ダウンロード用URLを送信します。
ダウンロードするファイルは、Windows ZIP形式です。

お問い合わせなど

プログラムのカスタマイズ(有償)、その他不具合やご質問などがありましたら、お気軽にお問い合わせフォームから、お問い合わせください。

表現・再現性に関するご注意 本プログラムをご利用になった結果の表現や再現性には分析に利用したデータの内容により違いがあり、すべてのお客様に対し、一定の表現や効果について必ずしも保証するものではありません。

例えば多変量解析などの場合では、体感している状況と分析結果が異なることや、わざわざ統計解析を利用して分析をしなくても、既にわかっている結果しか得られないという場合もあります。
思い通りの結果が得られなかったり、わかりきった結果が得られたのであれば、それは分析に使用したデータが、そのような内容しか表していないということなのです。

またお使いのパソコンが本プログラムの動作環境の通り、またはそれ以上の仕様であっても、本プログラムで処理しようとしているデータ量や作業工程により、処理に時間がかかる場合がございます。

 

Excel用アドインプログラム