人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセル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列の値とともに別ファイルに出力する)
( )でくくってある部分はわかれば教えてください。

ご協力お願いします。

●質問者: yuko0909
●カテゴリ:コンピュータ ウェブ制作
✍キーワード:A1 VBA xls ひらがな エクセル
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● SALINGER
●0ポイント

実行すると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
◎質問者からの返答

ありがとうございます。

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

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


2 ● Mook
●150ポイント

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

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


ひらがな処理は、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
◎質問者からの返答

ありがとうございます。

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

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


3 ● SALINGER
●200ポイント ベストアンサー

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


実行すると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
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ