Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2007/1/6  ユーザー名 : a
'
    Select Case Range("B1").Value
        Case Is = "": MsgBox "選択された主成分の数をオレンジのセルに入れてください"
        Case Else: PCAsoubetu
    End Select
    Range("B1").Select


End Sub

Sub PCAsoubetu()
'
'主成分層別法　Ver.1_1
'改定履歴
'2007.1.18　各主成分の32%値について層別作業を手動から自動にした


    Dim x!, p%, rownow%, colnow%, rowend%, datasu%, skijyun!, rowdown$, xcount%, S_PCA!, columnend%, score32!
    Dim PCAnow$
                                        'x:　スキャン時の各主成分スコア値
                                        'p:　主成分スコア列のスキャン作業用
                                        'rownow:　作業用。現在の行番号
                                        'colnow:　作業用。現在の列番号
                                        'rowend:　入力データの最下行の行番号
                                        'rowdown$:　Range領域指定用の文字列式
                                        'skijyun:　主成分層別基準数　（両側３２％値を推奨）
                                        'datasu:　ﾃﾞｰﾀの組数
                                        'S_PCA!: 　選択した主成分数
                                        'PCAnow:　各主成分の層別名称
                                        
    
    
    
    Range("C3").Select
    Selection.End(xlDown).Select
    rowend% = ActiveCell.Row
    datasu% = Cells(rowend%, 1).Value
    
    Selection.End(xlToRight).Select
    columnend% = ActiveCell.Column      'データ範囲の取得 end
    
    rowdown$ = "B3:B" & CStr(rowend%)
    With ActiveSheet
        .Cells(3, 2).Value = ""
        .Range(rowdown$).FillDown
    End With                            '主成分層別指標ゾーンのクリア end
    
    '主成分スコアの絶対値ソートと３２％値抽出
    
    '初期条件設定
    score32! = CInt(datasu% * 0.32)     '両側基準値を変えたい時は0.32の数値をかえると変更可能。
    
    Range("C3").Select
    rownow% = ActiveCell.Row
    colnow% = ActiveCell.Column
    S_PCA! = Cells(1, 2).Value
    
    For p% = 1 To S_PCA!
                '絶対値へ変換
        Do Until rownow% = rowend% + 1
        Range(Cells(rownow%, columnend% + 1), Cells(rownow%, columnend% + 1)).Select
        ActiveCell.Value = Abs(Cells(rownow%, colnow%).Value)
        rownow% = rownow% + 1
        Loop
                '降順へ　ソート
        Range(Cells(3, columnend% + 1), Cells(rowend%, columnend% + 1)).Select
    
        Selection.Sort Key1:=Range(Cells(3, columnend% + 1), Cells(3, columnend% + 1)), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
            :=xlPinYin
                
                '両側３２％出現値の選択と記入
        Cells(rownow% + 1, colnow%).Value = Cells(2 + score32!, columnend% + 1).Value
    
        rownow% = 3
        colnow% = colnow% + 1
    
    Next p%
    
                    '画面清掃
    Selection.Clear
    Range("B1").Select
    Cells(rowend% + 2, 1).Value = "両側３２％スコア値"
    
    
    '主成分層別作業開始
    Range("C3").Select
    rownow% = ActiveCell.Row

    colnow% = 3
    skijyun! = Cells(rowend% + 2, colnow%).Value
    
    For p% = 1 To Cells(1, 2).Value     '主成分の背番号分類作業
        Do
            x! = Cells(rownow%, colnow%).Value
            If Abs(x!) < skijyun! Then Cells(rownow%, 2).Value = Cells(rownow%, 2).Value & "" Else Cells(rownow%, 2).Value = Cells(rownow%, 2).Value & Str(p%)
            rownow% = rownow% + 1
        Loop Until rownow% = rowend% + 1
        
        rownow% = 3
        colnow% = colnow% + 1
        skijyun! = Cells(rowend% + 2, colnow%).Value
        
    Next p%                             '主成分層別終了
    
    rowdown$ = "3:" & CStr(rowend%)     'ソート
    Rows(rowdown$).Select
    Selection.Sort Key1:=Range("B3"), Order1:=xlAscending, Header:=xlNo, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlPinYin
    
End Sub