[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エラーで飛ばしたファイル名の取得（on error ）』（ムー）
複数ファイルのデータ転記処理を行っているのですが、その際取り込みファイルの型の違いによりどうしてもエラーが出てしまします。そこでon error go resume nextで飛ばしているのですが、その際どのファイルが飛ばしたかわからない状況なので以下の処理を加えていたのですが、教えていただけないでしょうか。
追加処理「飛ばしたファイル名とその取り込み日時をエラーシートに記録する。」
Sub データ()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim i As Long Dim tgtWb As Workbook, outWb As Workbook Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet Dim fname As String Dim cFld As String, outFld As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "取り込みフォルダ選択"
If .Show = True Then
cFld = .SelectedItems(1) & "\"
Else
Exit Sub
End If
.Title = "出力フォルダ選択"
If .Show = True Then
outFld = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Application.ScreenUpdating = False Application.DisplayAlerts = False Application.EnableEvents = False
fname = Dir(cFld & "*.xl*", vbNormal)
On Error Resume Next
Do Until fname = ""
Set tgtWb = Workbooks.Open(cFld & fname, UpdateLinks:=0)
Set sh2 = tgtWb.Sheets(1)
'対象ファイル名（拡張子なし）
Dim tgtWbNameShort As String
tgtWbNameShort = fso.GetBaseName(tgtWb.FullName)
'対象ファイルのSheet1(sh2)を新規ファイルにシートコピー
sh2.Copy
Set sh1 = ActiveSheet '転記先シート
Set outWb = sh1.Parent '転記先ファイル
Set sh3 = ThisWorkbook.Sheets(1)
sh1.Range("k4", "k5").UnMerge
sh3.Range("L4:L5").Copy sh1.Range("L4:L5")
sh3.Range("A30:A31").Copy sh1.Range("A30:A31")
sh1.Range("A30:C30").Merge
sh1.Range("A31:C31").Merge
sh1.Range("A30:C31").Borders.LineStyle = xlContinuous
'sh2→sh1転記（長いので割愛）
sh1.Range("K5").Value = sh2.Range("K10").Value
'対象ファイルのSheet2以降をシートコピー
For i = 2 To tgtWb.Sheets.Count
tgtWb.Sheets(i).Copy after:=outWb.Sheets(i - 1)
outWb.Sheets(i).Name = "A-" & i
Next i
outWb.Sheets(1).Name = "A-1"
'転記元ファイルClose
tgtWb.Close SaveChanges:=False
'転記先ファイルClose
outWb.Sheets(1).Activate
outWb.SaveAs Filename:=outFld & tgtWbNameShort & ".xlsx", FileFormat:=xlOpenXMLWorkbook
Workbooks(outWb.Name).Close
fname = Dir()
Loop
Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True MsgBox "終了しました。" End Sub
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
（γ） 2020/04/08(水) 18:45
よろしくお願い致します。
（ムー） 2020/04/08(水) 19:03
（γ） 2020/04/08(水) 22:46
マルチポストして他の掲示板でコードをもらったのかもしれませんが、それならそれで、事情を書いて同じトピックで、同じニックネームを使って話を続ければいいんじゃないでしょうか？
以下、ぱっと見気になるところ。
■１
＞取り込みファイルの型の違い
ファイルの型 ってなんですか？
Excelブック以外も開いちゃうという話なら、以前コメントしましたが、「"*.xl*"」→「"*.xls?"」で解決しませんか？
■２
問題はないでしょうけど、私が考えていたのはこんな感じでした。
tgtWb.Sheets(i).Copy after:=outWb.Sheets(i - 1)
↓
tgtWb.Sheets(i).Copy after:=outWb.Worksheets(outWb.Worksheets.Count)
■３
outWb.Sheets(i).Name = "A-" & i
↑は２つ目のブックを処理をしたときに、同じシート名があるのでエラーになりませんか？
(On Error Resume Nextで気づけなくなってますが)
■４
私見ですが、↓は完成後に付ければいいんじゃないでしょうか。試行錯誤してるときから設定しちゃうとデバッグ作業の邪魔になりそうです。
Application.ScreenUpdating Application.DisplayAlerts Application.EnableEvents
（もこな２ ） 2020/04/09(木) 07:29
「on errorステートメント VBA」
で調べてみました？
Resume以外の方法もあるということです。
Option Explicit
'#「Microsoft scripting runtime」 を参照設定すること
Dim mFSO As FileSystemObject
Sub test()
Set FSO = New FileSystemObject
Dim strPathFrom As String
Dim strPathTo As String
Dim f As File
Dim v() As Variant
Dim i As Long
Dim ix As Long
ReDim v(1 To 100000)
Set strPathFrom = GetMyFolder("取り込みフォルダ選択")
If Len(strPathFrom) = 0 Then Exit Sub
Set folTo = GetMyFolder("出力フォルダ選択")
If Len(strPathTo) = 0 Then Exit Sub
For Each f In mFSO.GetFolder(strPathFrom).Files
If mFSO.GetExtensionName(f) Like "xls?" Then
If SetCellsCopy(f, ThisWorkbook, folTo) = False Then
ix = ix + 1
v(ix) = f.Name
End If
End If
Next
'コピーに失敗したファイル名出力
ReDim Preserve v(1 To ix)
For i = 1 To ix
Debug.Print v(ix)
Next
End Sub
Function GetMyFolder(ByVal strProm As String) As String
.Title = strProm
If .Show = True Then
GetMyFolder = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End Function
Function SetCellsCopy(ByRef f As File, _
ByRef wbk As Workbook, _
ByVal sDirPath As String) As Boolean
Dim wbkOld As Workbook
Dim wshFrom As Worksheet
Dim wshTo As Worksheet
Set wbkOld = Workbooks.Open(f, 0)
Set wshFrom = wbkOld.Worksheets(1)
Set wshTo = wbk.Worksheets(1)
On Error GoTo WayOut
wshFrom.Range("L4:L5").Copy wshTo.Range("L4:L5")
On Error GoTo 0
SetCellsCopy = True
wshTo.Copy
With Workbooks(Workbook.Count)
SaveAs sDirPath & mFSO.GetBaseName(f) & ".xlsx"
Close
End With
WayOut:
wbkOld.Close False
End Function
ぱっと、思いついた感じで書くとこんな感じでしょうか？
動作確認してません。たぶんバグがあります。
構えというか、流れ？作業単位で関数に纏めてみたり、
全体の雰囲気を参考にしてもらえれば。
＞ 取り込みファイルの型の違いによりどうしてもエラーが出てしまします。
「各エクセルファイルのシート上のセルの結合の仕方の違いにより、
コピペでエラーがでることがある。」
という意味ですですよね？
エラーの出にくい作業の仕方やコードの書き方をまず覚えて、
事前にエラーになる条件が分かる場合にはIf文等で回避し、
それでもエラーが回避できない場合に、On Errorステートメントで、
最低限の範囲でエラー回避をするようにしてください。
そうしないと、他にもどこかでエラーが起きていても、
解らなくて、デバッグの作業が困難になります。
（まっつわん） 2020/04/09(木) 08:59
どうも、放置プレイをするのが好きな方のようですねぇ
回答ついてますがねぇ
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q13222791298
回答もまずいですねぇ... On Error Goto 0 で Errリセットされるのに．．． （うほほい） 2020/04/09(木) 10:28
>On Error Goto 0 で Errリセットされるのに．．．
リセットされたら何がまずいのでしょう。。。。。。。。。。。。。。。。。。。。。
まぁ、質問者さんがデバッグされてみて、まずいところを指摘してくれれば、
なにか考えるかもです。
こちらは、
放置されているとは思ってませんが、
結果的に放置になるのをどうのこうの言うつもりはありません。
こちらも次に何かアクションがあったとしても、それを見逃して、
結果的に放置になるかもしれませんし。
（まっつわん） 2020/04/09(木) 10:53
愚痴をご教示していただけないでしょうか。
どういう意味でしょうか？
（γ）
タイプミスです。すみません。具体をご教示〜〜みたいなことを書こうとしておりました。
もなこさん、まっつわんさん
いつもありがとうございます。
多忙でまだ試したりできてない状況です。すみません。
ちなみにエラーが出たファイルコピーして、エラーフォルダのような場所にコピーするといったことも可能なのでしょうか？そのほうが使う人にとっては便利かなあと思いまして。
別掲示板で聞いた件については、すみません。
ただ、別サイトのURLを貼るのはやめていただきたいです。
（ムー） 2020/04/09(木) 11:00
＞ちなみにエラーが出たファイルコピーして、エラーフォルダのような場所にコピーするといったことも可能なのでしょうか？ ＞そのほうが使う人にとっては便利かなあと思いまして。
どうも腑に落ちないなぁ。エラーを起こさせない方がもっといいんじゃないですか？
「取り込みファイルの型の違い」じゃなく、「セルの結合の仕方の違い」でエラーが出ていると言う見解が正しいなら、 コピペする前に、貼付先エリアの結合を解除しておけばいいんじゃないですか？
実際、自分でもやっているじゃないですか。(それをそのシーンで使うのが適切なのかは、こっちでは解からないですが）
↓
＞sh1.Range("k4", "k5").UnMerge
とにかく、On Error ・・ なんてのは外して、何がエラー原因なのか突き止めるのが先決です。
（半平太） 2020/04/09(木) 11:17
>リセットされたら何がまずいのでしょう リンク先の知恵袋の回答では、Errリセットしたあと Err.Number調べているので意味が無い （うほほい） 2020/04/09(木) 11:25
＞ただ、別サイトのURLを貼るのはやめていただきたいです。
えっと、他でも聞いているなら、
そのことをちゃんと話してください。
知らないところで話が進んで知らないうちに解決しているのは気分が悪いです。
こちらも考えてみているので、回答側に無駄な労力を強いらないよう気遣っていただけませんか？
＞残りの５％のファイルはそれがどのファイルでここのフォルダに移動したということまでできれば
それでいいかもですね。
コピペじゃなく値のみの転記なら、
結合セルが邪魔することなく転記出来ますが、
結局セルがずれてたらおかしなことになるかもなので、
今の方針でいいのではないでしょうか？
エラーが出ないようにするには、
シート上の状態が解らないのでちょっとどうしたらいいかを、
コメントするのは難しいかなと思います。
この辺はご自分の力量と相談かと思います。
ファイルの移動は出来ます。
まずは検索してみましょう。
（まっつわん） 2020/04/09(木) 11:47
そもそもこのサイトの「初めての方へ」の「(n) [マルチポストについて] 」に >•[マルチポストを見つけた方]がマルチポストであることを書くのも自由 >•そのサイトのアドレスも書くのも自由です と書かれてる。
（ねむねむ） 2020/04/09(木) 12:28
他にもマルチポストに関するここのサイトの方針が書かれているので上のメニューから 「初めての方へ」に飛んで読んでみてくれ。 （ねむねむ） 2020/04/09(木) 12:29
じゃ、エラー原因は「取り込みファイルの型の違い」で合っているんですね？
なら、ここでトラブっているんですね。
↓
＞Set tgtWb = Workbooks.Open(cFld & fname, UpdateLinks:=0)
エラーフォルダが仮にここに作ってあるとした場合 ↓ "C:\Users\User\Documents\ErrFolder\"
Sub データ() ＞ 省略 ＞ fname = Dir(cFld & "*.xl*", vbNormal)
Dim ErrNum, ErrFolder
ErrFolder = "C:\Users\User\Documents\ErrFolder\" '←エラーファイル貼り付け先(仮決め)
Do Until fname = ""
On Error Resume Next
Set tgtWb = Workbooks.Open(cFld & fname, UpdateLinks:=0)
ErrNum = Err.Number
On Error GoTo 0
If ErrNum = 0 Then
Set sh2 = tgtWb.Sheets(1)
＞ 省略 ＞ Workbooks(outWb.Name).Close
Else
FileCopy cFld & fname, ErrFolder & fname
End If
＞ fname = Dir() ＞ Loop
＞省略 ＞End Sub
（半平太） 2020/04/09(木) 12:41
1）拡張子はエクセルで開けそうだが、エクセルで開けない型のファイルが紛れている
2）ファイルは開けるが、シート上のセルの結合の形が違う
そこは、早目に明言された方がよいかと、、、、
（まっつわん） 2020/04/09(木) 13:56
sh1.Range("k4", "k5").UnMerge
sh3.Range("L4:L5").Copy sh1.Range("L4:L5")
sh3.Range("A30:A31").Copy sh1.Range("A30:A31")
sh1.Range("A30:C30").Merge
sh1.Range("A31:C31").Merge
sh1.Range("A30:C31").Borders.LineStyle = xlContinuous
上記部分でエラーの場合は、
On Error Resume Next
sh1.Range("k4", "k5").UnMerge
sh3.Range("L4:L5").Copy sh1.Range("L4:L5")
sh3.Range("A30:A31").Copy sh1.Range("A30:A31")
sh1.Range("A30:C30").Merge
sh1.Range("A31:C31").Merge
sh1.Range("A30:C31").Borders.LineStyle = xlContinuous
On Error GoTo 0
If ErrNum = 0 Then
以下省略
のような形で良いのでしょうか？
（ムー） 2020/04/09(木) 15:58
私の立場は、 １．ファイルが開けないなら、そのファイルをエラーフォルダーに放り込まざるを得ない。 その場合は、On Error Resume Next を使って行う。 ５%の手作業処理はやむを得ないと考える。
２．ファイルは開けるのだが、シート上にセルの結合があり、コピペがエラーになるなら、 On Error Resume は使う必要がない。（使うべきではない) 貼付け先エリアの結合を(コピペ直前に）解除すれば済むハズである。 結果として、エラーフォルダーに放り込むファイルなど１件も発生しない。 使う人は余計な手間がなくてハッピーになれる。
今回のトラブルは上記(２）の方なんですか？ 今一つ、確信が持てないんですよ。
実際に発生しているエラーコードは何なのですか。
何度も話が出ているように、コードからOn Error Resume Nextを排除すれば エラーで止まって、すぐ確認できることなんですけども。
そのエラーコードを明示して頂ければ、議論の余地がないと思うんですがねぇ。。
（半平太） 2020/04/09(木) 23:11
そうなると、そちらで「今回ばかりはどうしてもあまり時間がなく、コード化をお願いできませんでしょうか…」と仰ってるので、件の知恵袋に投稿されたコードも別のマルチポスト先で貰ったものを、そのまま張り付けたのではないでしょうか。
なので、皆さんが指摘しても（本人がコードを理解してないから）問題点がピンと来てないんじゃないですかねぇ・・・
とりあえず、
(1) 前トピックで２〜最後のシートまでループと言ってしまったけど
貰った？コードの動きが正解ならループする必要ないですね。
(2) 半平太さんが指摘されていますが。結局エラーになるのって、「L4:L5」セルが
他と結合されたままになっちゃうときくらいじゃないですかね？
それなら、貼付前に解除すればいいだけのように思います。
踏まえて、私なりに適当に手を入れてみるとこんな感じになりました。
Sub テキトー()
Dim logSH As Worksheet
Dim 処理フォルダ As String
Dim 保存フォルダ As String
Dim ログ行 As Long
Dim ブック名 As String
'▼ログ出力用シートを生成
On Error Resume Next
Set logSH = ThisWorkbook.Worksheets("log")
If logSH Is Nothing Then
Set logSH = Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
logSH.Name = "log"
logSH.Range("A1:C1").Value = Split("処理日時,フルパス,処理結果", ",")
End If
On Error GoTo 0
'▼フォルダの取得
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "取り込みフォルダ選択"
If .Show = True Then
処理フォルダ = .SelectedItems(1) & "\"
Else
Exit Sub
End If
.Title = "出力フォルダ選択"
If .Show = True Then
保存フォルダ = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
'▼ループ処理
ブック名 = Dir(処理フォルダ & "*.xls?")
Do Until ブック名 = ""
'▼ログシートに記録してから、全シートを丸ごと新規ブックへコピーしてすぐ閉じる
With Workbooks.Open(処理フォルダ & ブック名)
ログ行 = logSH.Cells(logSH.Rows.Count, "A").End(xlUp).Offset(1).Row
logSH.Cells(ログ行, "A").Value = Now()
logSH.Cells(ログ行, "B").Value = .FullName
.Worksheets.Copy
.Close
End With
'▼（コピーしてできた）新規ブックの処理
With Workbooks(Workbooks.Count)
On Error Resume Next
With .Worksheets(1)
With .Range("L4:L5")
.UnMerge
ThisWorkbook.Worksheets(1).Range(.Address).Copy .Cells
End With
With .Range("A30:C31")
.Merge True
.Borders.LineStyle = xlContinuous
End With
End With
If Err.Number = 0 Then
logSH.Cells(ログ行, "C").Value = "成功"
'// 成功したときだけシート名を変更してから保存
Call シート名変更(Workbooks(Workbooks.Count))
.SaveAs _
Filename:=保存フォルダ & Left(ブック名, InStrRev(ブック名, ".") - 1), _
FileFormat:=xlOpenXMLWorkbook
Else
logSH.Cells(ログ行, "C").Value = "失敗"
'// 失敗したときは、保存しない
Err.Clear
End If
On Error GoTo 0
'結果の成否にかかわらず、無条件で閉じる。（＝成功したときだけ保存される）
.Close False
ブック名 = Dir()
End With
Loop
End Sub
'------------------------------------------------------------------------------
Sub シート名変更(wb As Workbook)
Dim sh As Worksheet
On Error GoTo 重複時
For Each sh In wb.Worksheets
sh.Name = "A-" & sh.Index
Next sh
Err.Clear
Exit Sub
重複時:
wb.Worksheets("A-" & sh.Index).Name = wb.Worksheets("A-" & sh.Index).Name & "(1)"
Resume
End Sub
（もこな２ ） 2020/04/11(土) 13:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.