[[20160222193931]]　『同一フォルダ内のLogファイルをシートを分けて読ａx（よん）　ページの最後に飛ぶ

『同一フォルダ内のLogファイルをシートを分けて読み込みたい』（よん）

同一フォルダ内にある複数のLogファイルを1つのEXCELファイルにシートを分けて纏めたい。
以下でできましたが、Logファイルを「：」区切りで列を分け、読み込むことはできないでしょうか？

 logファイルは「:」を分岐に左右で分かれており
左に内容、右に数値が書かれてます。

Sub 複数ファイルを一つブックにまとめる()

     On Error GoTo ErrorHandler
     Dim strPath As String
     Dim strBookName As String
     Dim TargetBook As Workbook
     Dim OriginalSheet As Worksheet
     '同一フォルダ内にあるlogファイルをシートに追加する
     strPath = ThisWorkbook.Path '自分自身と同じ場所とする
     strBookName = Dir(strPath & "\*.log") 'ファイル名取得
     '対象ファイルが存在する限り処理
     Do While strBookName <> ""
         If ThisWorkbook.Name <> strBookName Then '自分自身じゃないなら
             'そのブックを開く
              Set TargetBook = Workbooks.Open(strPath & "\" & strBookName)

             'ここで「:」区切りで列を分けてLOGファイルを読み込みたい※※※※※※※※※

             '開いたブックの全てのシートを処理
             For Each OriginalSheet In TargetBook.Worksheets
                 '開いたブックのシートを自身の最後にコピー
                 OriginalSheet.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                 'コピーしたシートの名前をコピー元ブック名＆シート名に変更
                 'ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = TargetBook.Name & OriginalSheet.Name
                 'コピーしたシートの名前をコピー元シート名に変更
                 ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = OriginalSheet.Name
             Next
             '開いたブックを閉じる
             TargetBook.Close
             Set TargetBook = Nothing
         End If
         strBookName = Dir '次のファイル
     Loop
     Exit Sub
ErrorHandler:
     'エラーが起きたら
      If Not (TargetBook Is Nothing) Then
          TargetBook.Close
      End If
     If Err Then
         MsgBox Err.Number & ":" & Err.Description, vbExclamation
         Err.Clear
      End If

    Worksheets("まとめ").Select

 End Sub

＜使用アプリ：Excel2010、使用 OS：Windows7 ＞

・新しいシートを最後に追加し、
・そのシートに、以下の方法でlogファイルを読み込んではどうですか？
　　「データ」 - 「外部データの取り込み」 - 「テキストファイル」で
　　「区切り文字」を : と指定して読み込む作業をマクロ記録して、
　　これを修正してマクロに仕立てたらどうですか？

（γ） 2016/02/22(月) 21:48

ご教授ありがとうございます。

 以下を変えればうまくいくと思ってましたが試行錯誤しながらやってみます
              Set TargetBook = Workbooks.Open(strPath & "\" & strBookName)
（よん） 2016/02/22(月) 23:29

 To よん さん

 同じフォルダ内に、次の3つを置いて、(1)のマクロ実行ブックを実行してください。
 (1)マクロ実行ブック(Module1に次のコードを記述)
 (2)集約シート.xlsx（※「sheet1」あり）
    ※ログファイルのファイル名（.logを除いた名前）でなければ、シート名は何でもOK
 (3)ログ1.Log

 データ形式 (ログ1.Log)→「:」区切り文字
 +++++++++++++++++++++++++++++++++ 
あいうえお:かきくけこ
さしすせそ:たちつてと
 +++++++++++++++++++++++++++++++++

 とりあえず、ログファイル1つを処理するプログラムです。
 プログラムの修正→複数のログファイルのファイル名取得と、コピー処理のループ化。
 （*～*間の修正になるかと思います。）

 Option Explicit
 Sub Sample()
    Const DBook As String = "集約シート.xlsx" 'Destination_Book【コピー先】
    Const SFile1 As String = "ログ1.log" 'Source_File【コピー元】

    Dim SN As String 'Source_Sheet_Name
    Dim xd As Variant 'destination
    Dim logPath As Variant, wb As Workbook, flag As Boolean
    Dim sh As Worksheet, cnt As Long
        xd = ThisWorkbook.Path & "\" & DBook
    logPath = ThisWorkbook.Path & "\" & SFile1

    '【コピー先】を開く
    For Each wb In Workbooks
        If wb.Name = DBook Then flag = True '開いているか判定
    Next
    '存在していて、開いてなければ開く
    If Dir(xd) <> "" And flag = False Then Workbooks.Open xd
    '----------------------------------------------------------------------
 '************************************************************************************
    '【コピー元】を開く
    flag = False
    For Each wb In Workbooks
        If wb.Name = SFile1 Then flag = True
    Next
    If Dir(xd) <> "" And flag = False Then Workbooks.Open logPath
    SN = ActiveSheet.Name '「シート名：ログ1」
    '----------------------------------------------------------------------
    With Sheets(SN)
        .UsedRange.TextToColumns Other:=True, OtherChar:=":" '「:」区切り文字
         For Each sh In Workbooks(DBook).Sheets
             cnt = Workbooks(DBook).Sheets.Count
             If sh.Name = SN And cnt >= 2 Then
                Application.DisplayAlerts = False
                sh.Delete '「シート名：ログ1」が存在していたら削除
                Application.DisplayAlerts = True
             End If

         Next
        .Copy After:=Workbooks(DBook). _
         Sheets(Workbooks(DBook).Sheets.Count)  'コピー
         Workbooks(SFile1).Close SaveChanges:=False '閉じる（保存しない）★
    End With
   '----------------------------------------------------------------------
 '************************************************************************************
    Application.DisplayAlerts = False
    Workbooks(DBook).Close SaveChanges:=True '閉じる（保存する）★
    Application.DisplayAlerts = True
 End Sub

（マリオ） 2016/02/23(火) 11:15

 ■要点
 ログ1.logを開く
 Workbooks.Open logPath

 ログ1.logのテキストデータが、アクティブシートに貼りつく。アクティブシートの名前を取得。
 SN = ActiveSheet.Name

 アクティブシートで、区切り処理をする（区切り文字は、「:」）
 Sheets(SN).UsedRange.TextToColumns Other:=True, OtherChar:=":"

 区切り処理をしたデータをコピーして、コピー先(DBook)に
 Sheets(SN).Copy After:=Workbooks(DBook). Sheets(Workbooks(DBook).Sheets.Count)
（マリオ） 2016/02/23(火) 11:30

 SN「シート名：ログ1」があるブックを特定しておく
 （修正前）With Sheets(SN)
 （修正後）With Workbooks(SFile1).Sheets(SN)
（マリオ） 2016/02/23(火) 12:24

 'マクロ実行ブックと同じフォルダ内にある複数のLogファイルのデータを、
 'アクティブブックに、シート分けして取り込んでいく。
 '取込終了後、アクティブブックを「yymmdd_HHmmss.xlsx」の名前で保存して閉じる（マクロ実行ブックと同じフォルダ）。

 Option Explicit
 Sub Sample3()
    Dim SaveFile As String
    Dim DBook As String
    Dim SN As String, xs As Variant
    Dim wb As Workbook, flag As Boolean
    Dim sh As Worksheet, cnt As Long
    Dim Path As String, buf As String, i As Long, j As Long, rv As Integer
    ReDim Book(1 To 1) As String
    Path = ThisWorkbook.Path & "\": buf = Dir(Path & "*.log")
    Do While buf <> ""
        i = i + 1: ReDim Preserve Book(1 To i): Book(i) = buf: buf = Dir()
    Loop
    Workbooks.Add '新規ブック作成
    DBook = ActiveWorkbook.Name
    rv = MsgBox("Logファイル：（" & i & "個）" & vbCrLf & _
                "処理を行いますか？", vbYesNo + vbQuestion, "確認")
    If rv = vbNo Then
       Workbooks(DBook).Close
       End
    End If
    With Application
      .ScreenUpdating = False
      .Calculation = xlCalculationManual
      .EnableEvents = False
    End With
 '************************************************************************************
    For j = 1 To i
        flag = False
        For Each wb In Workbooks
            If wb.Name = Book(j) Then flag = True
        Next
        xs = ThisWorkbook.Path & "\" & Book(j) 'source
        If Dir(xs) <> "" And flag = False Then Workbooks.Open xs '開く（コピー元）
        SN = ActiveSheet.Name 'Source_Sheet_Name

        With Workbooks(Book(j)).Sheets(SN)
            .UsedRange.TextToColumns Other:=True, OtherChar:=":" '「:」区切り文字
            .UsedRange.EntireColumn.AutoFit '幅自動調整

             For Each sh In Workbooks(DBook).Sheets
                 cnt = Workbooks(DBook).Sheets.Count
                 If sh.Name = SN And cnt >= 2 Then 'シート名(SN)が既にあるなら
                    Application.DisplayAlerts = False
                    sh.Delete '削除
                    Application.DisplayAlerts = True
                 End If
             Next
            .Copy After:=Workbooks(DBook).Sheets(Workbooks(DBook).Sheets.Count) 'コピー
             Workbooks(Book(j)).Close SaveChanges:=False '保存せず、閉じる
             Application.ScreenUpdating = True
                 DoEvents
                 Workbooks(DBook).Activate
                 Application.StatusBar = "処理実行中．．．．(現在 " & j & "件)"
             Application.ScreenUpdating = False
        End With
    Next j
 '************************************************************************************
    With Application
      .ScreenUpdating = True
      .Calculation = xlCalculationAutomatic
      .EnableEvents = True
      .StatusBar = False
    End With                                      
   '終了処理-------------------
    For Each sh In Workbooks(DBook).Sheets
        cnt = Workbooks(DBook).Sheets.Count
        If sh.Name = "Sheet1" And cnt >= 2 Then 'シート名(Sheet1)があるなら
           Application.DisplayAlerts = False
           sh.Delete '削除
           Application.DisplayAlerts = True
        End If
    Next        
    Workbooks(DBook).Activate
    SaveFile = Format(Date, "yymmdd") & "_" & Format(Now(), "HHmmss")
    MsgBox "処理が終わりました。" & vbCrLf & _
           "「" & DBook & "」を次の名前で保存後、閉じます。" & vbCrLf & _
           "「" & SaveFile & ".xlsx」"     
    Application.DisplayAlerts = False
         Workbooks(DBook).SaveAs ThisWorkbook.Path & "\" & SaveFile '★上書き確認せず保存
         Workbooks(SaveFile).Close
        'ThisWorkbook.Save
        'If Workbooks.Count <= 1 Then Application.Quit
        'ThisWorkbook.Close
    Application.DisplayAlerts = True
 End Sub
（マリオ） 2016/02/23(火) 15:58

 Sample3プロシージャをアップした後ではありますが、

 Sampleプロシージャ、間違ってました。
 Dir(xd)→Dir(logPath)
 （訂正前）If Dir(xd) <> "" And flag = False Then Workbooks.Open logPath
 （訂正後）If Dir(logPath) <> "" And flag = False Then Workbooks.Open logPath

（マリオ） 2016/02/23(火) 16:06

マリオ様
詳細にご教授いただき誠に感謝です。
解決しうまく処理することができました。
こういった場があり、ご丁寧に全てソースを
記載いただき申し訳ありません
また、返信遅れたことを重ねてお詫び致します。
（よん） 2016/02/25(木) 15:17

コメント返信：

[ 一覧(最新更新順) ]

[[20160222193931]] 『同一フォルダ内のLogファイルをシートを分けて読ａx（よん） ページの最後に飛ぶ

[[20160222193931]]　『同一フォルダ内のLogファイルをシートを分けて読ａx（よん）　ページの最後に飛ぶ