エクセルVBAについて質問です。

マクロでエラーログを吐き出す方法を教えてください。

例)a1.xlsのシート1のA列、B列、C列、D列、E列に値が入っている
  ・A列の値をa1.xlsのシート2のA列に出力する。
  ・B列の値が50文字以下ならa1.xlsのシート2のB列に出力する。
  ・B列の値が50文字以上ならa1.xlsのシート2のB列に出力はせず、エラーとして別ファイルにA列の値とともに出力する。
  ・C列の値とD列の値をくっつけた値が100文字以下ならa1.xlsのシート2のC列に出力する。
  ・C列の値とD列の値をくっつけた値が100文字以上ならa1.xlsのシート2のC列に出力せず、エラーとしてA列の値とともに別ファイルに出力する。
  (・E列の値がひらがなならa1.xlsのシート2のE列に出力する)
  (・E列の値がひらがな以外ならエラーとしてA列の値とともに別ファイルに出力する)
( )でくくってある部分はわかれば教えてください。

ご協力お願いします。

回答の条件
  • 1人5回まで
  • 登録:2009/02/03 22:27:04
  • 終了:2009/02/04 22:16:14

ベストアンサー

id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/04 08:13:25

ポイント200pt

先の回答に間違いがあったので修正します。


実行するとa1.xlsと同じ場所にlog.txtという名前でエラーログを作ります。

ログなので前のログを残して追記するようにしていますが、常に新規で書き込むときは1行目を2にしてください。

以下と以上だと重なる部分があるので、以下とより大きいと読み替えました。

ひらがなの判別では、ひらがなとそれ以外が混在している場合もあるので、全てひらがなの場合としました。


Option Explicit

Sub MacroErrLog()
    '8の場合追記、2の場合新規
    Const num As Integer = 8
    Dim lastRow As Long
    Dim i As Long
    Dim s As String
    Dim FSO
    Dim TextFile
    Dim log As String
    
    '1行目からデータが入っているとして
    lastRow = Sheet1.UsedRange.Rows.Count
    
    With Sheet1
        For i = 1 To lastRow
        
            'A列の値をa1.xlsのシート2のA列に出力する。
            Sheet2.Cells(i, "A").Value = .Cells(i, "A").Value
            
            'B列の値が50文字以下ならa1.xlsのシート2のB列に出力する。
            If Len(.Cells(i, "B").Value) <= 50 Then
                Sheet2.Cells(i, "B").Value = .Cells(i, "B").Value
            Else
            
                'B列の値が50文字以上ならa1.xlsのシート2のB列に出力はせず、
                'エラーとして別ファイルにA列の値とともに出力する。
                Sheet2.Cells(i, "B").Value = ""
                log = log & .Cells(i, "A").Value & " " & .Cells(i, "B").Value & vbNewLine
            End If
            
            'C列の値とD列の値をくっつけた値が100文字以下ならa1.xlsのシート2のC列に出力する。
            s = .Cells(i, "C").Value & .Cells(i, "D").Value
            If Len(s) <= 100 Then
                Sheet2.Cells(i, "C").Value = s
            Else
                
                'C列の値とD列の値をくっつけた値が100文字以上ならa1.xlsのシート2のC列に出力せず、
                'エラーとしてA列の値とともに別ファイルに出力する。
                Sheet2.Cells(i, "C").Value = ""
                log = log & .Cells(i, "A").Value & " " & s & vbNewLine
            End If
            
            'E列の値がひらがなならa1.xlsのシート2のE列に出力する
            If hiragana(.Cells(i, "E").Value) Then
                Sheet2.Cells(i, "E").Value = .Cells(i, "E").Value
            Else
            
                'E列の値がひらがな以外ならエラーとしてA列の値とともに別ファイルに出力する
                Sheet2.Cells(i, "E").Value = ""
                log = log & .Cells(i, "A").Value & " " & .Cells(i, "E").Value & vbNewLine
            End If
        Next i
    End With
    
    'エラーログが無ければ抜ける
    If log = "" Then Exit Sub
    
    'エラーログの書き出し
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    With FSO.OpenTextFile(ThisWorkbook.Path & "\log.txt", num, True)
        .WriteLine log
    End With
    
    Set FSO = Nothing
End Sub

'全てひらがなの場合True
Function hiragana(str As String) As Boolean
    Dim i As Integer
    Dim f As Boolean
    f = True
    For i = 1 To Len(str)
        If Asc(Mid$(str, i, 1)) < -32096 Or Asc(Mid$(str, i, 1)) > -32015 Then
            f = False
        End If
    Next i
    hiragana = f
End Function

その他の回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/03 23:50:45

実行するとa1.xlsと同じところにlog.txtというファイルを作ります。

以下と以上でダブル部分がありますが、以下とより大きいと読み替えました。

ログということで追記モードになっていますが、途中の引数を2に変えれば新規モードとなります。


Option Explicit

Sub Macro1()
    Dim lastRow As Long
    Dim i As Long
    Dim s As String
    Dim FSO
    Dim TextFile
    Dim log As String
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    With Sheet1
        For i = 1 To lastRow
            Sheet2.Cells(i, "A").Value = .Cells(i, "A").Value
            
            If Len(.Cells(i, "B").Value) <= 50 Then
                Sheet2.Cells(i, "B").Value = .Cells(i, "B").Value
            Else
                Sheet2.Cells(i, "B").Value = ""
                log = .Cells(i, "A").Value & " " & .Cells(i, "B").Value
            End If
            
            s = .Cells(i, "C").Value & .Cells(i, "D").Value
            If Len(s) <= 100 Then
                Sheet2.Cells(i, "C").Value = s
            Else
                Sheet2.Cells(i, "C").Value = ""
                If log <> "" Then
                    log = log & vbNewLine & .Cells(i, "A").Value & " " & s
                Else
                    log = .Cells(i, "A").Value & " " & s
                End If
            End If
            
            If hiragana(.Cells(i, "E").Value) Then
                Sheet2.Cells(i, "E").Value = .Cells(i, "E").Value
            Else
                Sheet2.Cells(i, "E").Value = ""
                If log <> "" Then
                    log = log & vbNewLine & .Cells(i, "A").Value & " " & .Cells(i, "E").Value
                Else
                    log = .Cells(i, "A").Value & " " & .Cells(i, "E").Value
                End If
            End If
        Next i
    End With
    
    '引数を8の場合追記、2の場合新規
    With FSO.OpenTextFile(ThisWorkbook.Path & "\log.txt", 8, True)
        .WriteLine log
    End With
    
    Set FSO = Nothing
End Sub

Function hiragana(str As String) As Boolean
    Dim i As Integer
    Dim f As Boolean
    f = True
    For i = 1 To Len(str)
        If Asc(Mid$(str, i, 1)) < -32096 Or Asc(Mid$(str, i, 1)) > -32015 Then
            f = False
        End If
    Next i
    hiragana = f
End Function
id:yuko0909

ありがとうございます。

修正していただいたマクロを実行してみたら、まさにわたしがしたかったことができました!!

返事が遅くなってしまい、申し訳ありません。

2009/02/04 22:15:12
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912009/02/04 00:05:39

ポイント150pt

標準モジュールに下記のコードをコピーし、

★の部分を実際のデータに合わせて実行してみてください。


ひらがな処理は、1文字でもひらがなでないものが含まれている場合をエラーとしました。

エラーは、A列に理由と対象セル、B列に元データのA列のデータ、C列に元データの問題データを書き出しています。

Option Explicit
Const filePath = "C:\Data\a1.xls"  '★★★ 実際のパスを指定

'--------------------------------------------
Sub main()
'--------------------------------------------
    Dim srcWS As Worksheet
    Set srcWS = openWorkSheet(filePath, "シート1")  '★★★ 処理データのシートを指定
    
    If srcWS Is Nothing Then
        MsgBox "該当シートがありません"
        Exit Sub
    End If
    
    Dim dstWS As Worksheet
    Set dstWS = openWorkSheet(filePath, "シート2") '★★★ 処理結果のシートを指定
    If dstWS Is Nothing Then
        MsgBox "該当シートがありません"
        Exit Sub
    End If
    
    Dim errWB As Workbook
    Set errWB = Workbooks.Add()

    Dim errWS As Worksheet
    Set errWS = errWB.Worksheets(1)
    
    Dim lastRow As Long
    lastRow = srcWS.Range("A" & Rows.Count).End(xlUp).Row
    
    Dim r As Range
    Dim eRow As Long
    For Each r In srcWS.Range("A1").Resize(lastRow, 1)
'★B列 50文字判定
        dstWS.Cells(r.Row, "A") = r
        If Len(r.Offset(0, 1).Value) > 50 Then
            eRow = eRow + 1
            errWS.Cells(eRow, "A").Value = "ERR(B" & r.Row & ") B列が50文字より長い"
            errWS.Cells(eRow, "B").Value = r.Value
            errWS.Cells(eRow, "C").Value = r.Offset(0, 1).Value
        Else
            dstWS.Cells(r.Row, "B").Value = r.Offset(0, 1).Value
        End If
        
'★C+D列 100文字判定
        If Len(r.Offset(0, 2).Value) + Len(r.Offset(0, 3).Value) > 100 Then
            eRow = eRow + 1
            errWS.Cells(eRow, "A").Value = "ERR(C" & r.Row & ":D" & r.Row & ") C+D列が100文字より長い"
            errWS.Cells(eRow, "B").Value = r.Value
            errWS.Cells(eRow, "C").Value = r.Offset(0, 2).Value & r.Offset(0, 3).Value
        Else
            dstWS.Cells(r.Row, "C").Value = r.Offset(0, 2).Value & r.Offset(0, 3).Value
        End If

'★E列ひらがな判定
        If isHiragana(r.Offset(0, 4).Value) = False Then
            eRow = eRow + 1
            errWS.Cells(eRow, "A").Value = "ERR(E" & r.Row & ") E列がひらがなではありません"
            errWS.Cells(eRow, "B").Value = r.Value
            errWS.Cells(eRow, "C").Value = r.Offset(0, 4).Value
        Else
            dstWS.Cells(r.Row, "E").Value = r.Offset(0, 4).Value
        End If
    Next
End Sub

'--------------------------------------------
Function isHiragana(dt As String) As Boolean
'--------------------------------------------
    Dim s As Integer
    isHiragana = False
    For s = 1 To Len(dt)
        If Asc(Mid(dt, s, 1)) < -32097 Then Exit Function
        If Asc(Mid(dt, s, 1)) > -32015 Then Exit Function
    Next
    isHiragana = True
End Function


'--------------------------------------------
Function openWorkSheet(bookPath As String, sheetName As String) As Worksheet
'--------------------------------------------
    Dim bookName As String
    bookName = Mid(bookPath, InStrRev(bookPath, "\") + 1)
    
    Dim wb As Workbook
    On Error Resume Next
    Set wb = Workbooks(bookName)
    
    If wb Is Nothing Then
        Set wb = Workbooks.Open(bookPath)
    End If
    
    Set openWorkSheet = wb.Worksheets(sheetName)
    On Error GoTo 0
End Function
id:yuko0909

ありがとうございます。

コメントが記載してあってとてもわかりやすかったです。

返事が遅くなってしまい、申し訳ありません。

2009/02/04 22:15:27
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/02/04 08:13:25ここでベストアンサー

ポイント200pt

先の回答に間違いがあったので修正します。


実行するとa1.xlsと同じ場所にlog.txtという名前でエラーログを作ります。

ログなので前のログを残して追記するようにしていますが、常に新規で書き込むときは1行目を2にしてください。

以下と以上だと重なる部分があるので、以下とより大きいと読み替えました。

ひらがなの判別では、ひらがなとそれ以外が混在している場合もあるので、全てひらがなの場合としました。


Option Explicit

Sub MacroErrLog()
    '8の場合追記、2の場合新規
    Const num As Integer = 8
    Dim lastRow As Long
    Dim i As Long
    Dim s As String
    Dim FSO
    Dim TextFile
    Dim log As String
    
    '1行目からデータが入っているとして
    lastRow = Sheet1.UsedRange.Rows.Count
    
    With Sheet1
        For i = 1 To lastRow
        
            'A列の値をa1.xlsのシート2のA列に出力する。
            Sheet2.Cells(i, "A").Value = .Cells(i, "A").Value
            
            'B列の値が50文字以下ならa1.xlsのシート2のB列に出力する。
            If Len(.Cells(i, "B").Value) <= 50 Then
                Sheet2.Cells(i, "B").Value = .Cells(i, "B").Value
            Else
            
                'B列の値が50文字以上ならa1.xlsのシート2のB列に出力はせず、
                'エラーとして別ファイルにA列の値とともに出力する。
                Sheet2.Cells(i, "B").Value = ""
                log = log & .Cells(i, "A").Value & " " & .Cells(i, "B").Value & vbNewLine
            End If
            
            'C列の値とD列の値をくっつけた値が100文字以下ならa1.xlsのシート2のC列に出力する。
            s = .Cells(i, "C").Value & .Cells(i, "D").Value
            If Len(s) <= 100 Then
                Sheet2.Cells(i, "C").Value = s
            Else
                
                'C列の値とD列の値をくっつけた値が100文字以上ならa1.xlsのシート2のC列に出力せず、
                'エラーとしてA列の値とともに別ファイルに出力する。
                Sheet2.Cells(i, "C").Value = ""
                log = log & .Cells(i, "A").Value & " " & s & vbNewLine
            End If
            
            'E列の値がひらがなならa1.xlsのシート2のE列に出力する
            If hiragana(.Cells(i, "E").Value) Then
                Sheet2.Cells(i, "E").Value = .Cells(i, "E").Value
            Else
            
                'E列の値がひらがな以外ならエラーとしてA列の値とともに別ファイルに出力する
                Sheet2.Cells(i, "E").Value = ""
                log = log & .Cells(i, "A").Value & " " & .Cells(i, "E").Value & vbNewLine
            End If
        Next i
    End With
    
    'エラーログが無ければ抜ける
    If log = "" Then Exit Sub
    
    'エラーログの書き出し
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    With FSO.OpenTextFile(ThisWorkbook.Path & "\log.txt", num, True)
        .WriteLine log
    End With
    
    Set FSO = Nothing
End Sub

'全てひらがなの場合True
Function hiragana(str As String) As Boolean
    Dim i As Integer
    Dim f As Boolean
    f = True
    For i = 1 To Len(str)
        If Asc(Mid$(str, i, 1)) < -32096 Or Asc(Mid$(str, i, 1)) > -32015 Then
            f = False
        End If
    Next i
    hiragana = f
End Function
  • id:SALINGER
    先の回答には特定のときに正しいログを吐かないバグがあったので修正しました。
    1のほうはオープンしないでください。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません