« 2015年10月 | トップページ | 2016年1月 »

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

Sub ☆テキスト読み込み()
   
    fileOpenName = Application.GetOpenFilename("*.Textファイル (*.Txt), *.Txt", MultiSelect:=True, Title:="★★★ ファイル選択 ★★★")
   
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    If IsArray(fileOpenName) Then
        For fcnt = 1 To UBound(fileOpenName)
            
            'ファイル読み込み
            Workbooks.OpenText Filename:=fileOpenName(fcnt), Origin:=xlWindows, _
                StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False _
                , Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
                TrailingMinusNumbers:=True
            Set ActWb = ActiveWorkbook
            Set ActWs = ActWb.Sheets(1)
            
            Range("A11").Select
            Range(Selection, Selection.End(xlDown)).Select
            
            '分割
            Selection.TextToColumns Destination:=Range("A11"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                :="[", FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
            
            Range("B11").Select
            Range(Selection, Selection.End(xlDown)).Select
            
            '文字列置換
            Columns("B:B").Select
            Selection.Replace What:="SJIS]: ", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
               
            lMax = ActWs.Cells(65000, "A").End(xlUp).Row
            For i = 11 To lMax - 1
                lPath = ActWs.Cells(i, "A").Value
                lSp1 = InStrRev(lPath, "\")
                lSp2 = InStrRev(lPath, "\", lSp1 - 1)
                ActWs.Cells(i, "C").Value = "'" & Replace(Mid(ActWs.Range("A2").Value, InStr(ActWs.Range("A2").Value, """")), """", "")
                ActWs.Cells(i, "D").Value = ActWs.Name
                ActWs.Cells(i, "F").Value = Mid(lPath, lSp1 + 1)
                ActWs.Cells(i, "F").Value = Mid(ActWs.Cells(i, "F").Value, 1, InStr(ActWs.Cells(i, "F").Value, "(") - 1)
                ActWs.Cells(i, "E").Value = Mid(lPath, lSp2 + 1, lSp1 - lSp2 - 1)
                If i = 75 Then
                    xxxx = 1
                End If
                lVal = StrConv(ActWs.Cells(i, "B").Value, vbLowerCase)
                lKen = StrConv(ActWs.Cells(i, "C").Value, vbLowerCase)
                lLenMax = Len(ActWs.Cells(i, "B").Value)
                lLen = Len(ActWs.Cells(i, "C").Value)
                For j = 1 To lLenMax
                    lSp3 = InStr(j, lVal, lKen)
                    If lSp3 <> 0 Then
                        With ActWs.Cells(i, "B").Characters(Start:=lSp3, Length:=lLen).Font
                            .ColorIndex = 3
                        End With
                        j = lSp3
                    Else
                        Exit For
                    End If
                Next

            Next
            Application.ReferenceStyle = xlA1
            ActWs.Range("G9").Formula = "=COUNTIF(G11:G" & lMax & ",""○"")"
            With ActWs.Range("G9").Interior
                .Color = 65535
            End With
            With ActWs.Range("G9").Font
                .Color = -16776961
            End With
            

            ActWs.Range("C10:G10") = Array("検索条件", "修正No", "抽出フォルダ", "抽出ファイル名", "判定")
            Columns("C:G").Select
            Columns("C:G").EntireColumn.AutoFit
            
        Next
'        MsgBox "処理が完了しました。"
    End If

    Set ActWb = Nothing
    Set ActWs = Nothing
   

   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = False

End Sub

« 2015年10月 | トップページ | 2016年1月 »