2017年6月
        1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30  

« VBA雑記帳1213 | トップページ | VBA雑記帳0107 »

2015年12月13日 (日)

VBA雑記帳1213_2

Sub ☆Iro_Henko_test()

'    Call ☆Iro_Henko(ActiveSheet, xlOff)
    Call ☆Iro_Henko(ActiveSheet, xlOn)

End Sub

Function ☆Iro_Henko(ByVal pWs, ByVal pFlg)
    Const cSetCol As String = "O"
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
   
    If pFlg = xlOff Then
'        Set rtn = pWs.Cells.Find(a)
        pWs.Range("A1").Select
        With Application.FindFormat.Interior
            .PatternColorIndex = xlAutomatic
            .Color = 12632256
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Set rtn = pWs.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , MatchByte:=False, SearchFormat:=True)
       
        If Not rtn Is Nothing Then
            pWs.Cells(rtn.Row, cSetCol).Value = rtn.Address
            
            '灰色どこまでか横方向検索
            lCol = rtn.Column
            Do While pWs.Cells(rtn.Row, lCol).Interior.Color = 12632256
                lMaxAdd = pWs.Cells(rtn.Row, lCol).Address
                lCol = lCol + 1
            Loop
            pWs.Cells(rtn.Row, cSetCol).Value = pWs.Cells(rtn.Row, cSetCol).Value & ":" & lMaxAdd
            
            '灰色どこまでか縦方向検索
            lStAddress = rtn.Address
            Set rtn2 = rtn.Offset(1, 0)
            rtn2.Activate
            Do
               
                Set rtn2 = pWs.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , MatchByte:=False, SearchFormat:=True)
                If Not rtn2 Is Nothing Then
                    If rtn2.Address = lStAddress Then Exit Do
               
                    pWs.Cells(rtn2.Row, cSetCol).Value = rtn2.Address
                    '灰色どこまでか横方向検索
                    lCol = rtn2.Column
                    Do While pWs.Cells(rtn2.Row, lCol).Interior.Color = 12632256
                        lMaxAdd = pWs.Cells(rtn2.Row, lCol).Address
                        lCol = lCol + 1
                    Loop
                    pWs.Cells(rtn2.Row, cSetCol).Value = pWs.Cells(rtn2.Row, cSetCol).Value & ":" & lMaxAdd
                   
                   
                    Set rtn2 = rtn2.Offset(1, 0)
                    rtn2.Activate
            
                End If
            Loop
            
        End If
    Else
        lMax = pWs.Cells(65000, cSetCol).End(xlUp).Row
        For i = 1 To lMax
            i = pWs.Cells(i, cSetCol).End(xlDown).Row
               
            Do While i <= lMax
               
                With pWs.Range(pWs.Cells(i, cSetCol).Value).Interior
                    .Color = 12632256
                End With
                pWs.Cells(i, cSetCol).Value = ""
               
                i = pWs.Cells(i, cSetCol).End(xlDown).Row
            Loop
        Next
   
    End If
   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = False

End Function

« VBA雑記帳1213 | トップページ | VBA雑記帳0107 »

VBScript」カテゴリの記事

コメント

コメントを書く

(ウェブ上には掲載しません)

« VBA雑記帳1213 | トップページ | VBA雑記帳0107 »