2017年12月
          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
31            

« ネット通販詐欺に遭いました | トップページ | VBA雑記帳1213_2 »

2015年12月13日 (日)

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

« ネット通販詐欺に遭いました | トップページ | VBA雑記帳1213_2 »

VBScript」カテゴリの記事

コメント

コメントを書く

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

« ネット通販詐欺に遭いました | トップページ | VBA雑記帳1213_2 »