Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : Excel 2021)
マクロが突然エラーになるようになりました。
投稿日時: 24/02/20 09:59:08
投稿者: りさこ

Excel VBAについて質問です。
 
以下のコードを毎日使用しています。
 
----------------------------------------------------------------------------------
Sub 集約()
   '都度指定のフォルダ内の「速報」シートだけを値で集める ---------------
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "フォルダ選択"
        If .Show = True Then
            Dim bkFolder As String: bkFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    Dim bkName As String: bkName = Dir(bkFolder & "\*.xlsx")
    Application.ScreenUpdating = False
    Do While bkName <> ""
        Dim wbk As Workbook
        'UpdateLinks0で外部リンクの更新メッセージをなしにする
        Set wbk = Workbooks.Open(bkFolder & "\" & bkName, UpdateLinks:=0)
        Dim srcSh As Worksheet
        On Error Resume Next
        Set srcSh = wbk.Worksheets("速報")
        On Error GoTo 0
        If Not srcSh Is Nothing Then
            srcSh.UsedRange.Copy
            srcSh.UsedRange.PasteSpecial xlPasteValues
            srcSh.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
            '頭から↓で指定の文字数のシート名に設定する
            ActiveSheet.Name = Left(wbk.Name, 30)
        End If
        Set srcSh = Nothing
        wbk.Close False
        bkName = Dir()
    Loop
    Application.ScreenUpdating = True
   
'行列入れ替え ------------------------------------------------------------------------
   
Dim WS As Worksheet
    Dim ce As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    For Each WS In Worksheets
            If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "ぺた" Then
            WS.Range("A1:D1,A2:N2,A15:D15,A16:N16").UnMerge
            For Each ce In WS.Range("B2:N2,B16:N16")
                If IsEmpty(ce) Then ce.Value = ce.Offset(0, -1).Value
            Next
            WS.Range("A1").Copy Destination:=WS.Range("P1:P14")
            WS.Range("A2:N13").Copy
            WS.Range("Q1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
            WS.Range("A15").Copy Destination:=WS.Range("P15:P28")
            WS.Range("A16:N27").Copy
            WS.Range("Q15").PasteSpecial Paste:=xlPasteValues, Transpose:=True
            WS.Range("A:O,S:S,U:U,W:W,Y:Y,AA:AA").Delete
            WS.Range("A:H").ClearFormats
            WS.Range("B1:B28").NumberFormatLocal = "m月d日(aaa)"
            WS.Range("A:H").Columns.AutoFit
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
'全てのシートのA1を選択して終わる --------------------------------------------------------
   
  Dim WB As Workbook
  Set WB = ThisWorkbook
     
  For Each WS In WB.Worksheets
    WS.Activate
    WS.Cells(1, 1).Select
  Next
     
   
'貼付用のデータを作成する。--------------------------------------------------------
   
    Dim cnt As Long
    Dim 貼付sh As Worksheet
    Set 貼付sh = Worksheets("貼付用")
    Dim lastRow As Long, i As Long
    Dim sh
    cnt = 2
    For Each sh In Worksheets
        If sh.Name <> "集約" And sh.Name <> "貼付用" And sh.Name <> "ぺた" Then
            lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
           For i = 1 To lastRow
                sh.Range("A" & i & ":H" & i).Copy Destination:=貼付sh.Cells(cnt, "B")
                cnt = cnt + 1
            Next i
        End If
    Next sh
 
Sheets("ぺた").Activate
           
End Sub
----------------------------------------------------------------------------------
 
昨日まで何の問題もなく使えていたのに、突然今日、特定の部分で使えなくなってしまいました。
引っかかるのは、この一文です。
Set wbk = Workbooks.Open(bkFolder & "\" & bkName, UpdateLinks:=0)
 
エラー内容は
「実行時エラー'1004' 'Open'メソッドは失敗しました。'Workbooks'オブジェクト」です。
 
Excel側の設定も変更していませんし、なぜ突然止まってしまうのかわかりません。
何か原因がありそうでしたらご教授ください。
[/code]

回答
投稿日時: 24/02/20 10:34:33
投稿者: WinArrow

引用:

「実行時エラー'1004' 'Open'メソッドは失敗しました。'Workbooks'オブジェクト」です。

このエラーは、
ファイルの場所を示す「bkFolder & "\" & bkName」が、間違っていること起因しています。
「bkFolder & "\" & bkName」の値のファイルが存在しないということでしょうう。
  
各々の変数を確認してみてください。
  
エラーになったところで、黄色で止まているので、
変数にカーソルを当てると、変数の値が表示されます。

回答
投稿日時: 24/02/20 11:15:37
投稿者: WinArrow

アドバイス
コードでは、ファイルが格納されているフォルダを選択後
フォルダ内のExcelファイルをDir関数で取得していますが、
若し、選択したフォルダが間違っていても、そのまま実行されて、
意図しないところでエラーになる可能性があります。
処理に最も必要なのは、ファイルであると思います。
ファイルが間違っていても、例えば、前年度のファイルは、エラーにならずに処理できてしまいます。
コードの中では、ファイル名に関してはノーチェックです。
 
いままで、無事に動いたのは運が良かっただけと思います。
 
>Application.FileDialog(msoFileDialogFolderPicker)
の代わりに
Application.GetOpenFilename
を紹介します。
一度に複数のファイルを取得可能です。
 
参考例

  Dim FileName As Variant
  FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*", _
                        MultiSelect:=True)
  If Not IsArray(FileName) Then
    Exit Sub
  End If

 
 
 
 

回答
投稿日時: 24/02/20 12:09:31
投稿者: QooApp

ミス事例添えておきます
 
正解:C:\A\B\C.xlsx
誤例:C:\A\B\D.xlsx ファイル名ミス
誤例:C:\A\B\\C.xlsx \マークがダブってる
誤例:C:\A\C.xlsx フォルダが違う
誤例:c.xlsx(と見せかけた、拡張子を手動で.txtから書き換えたもの
誤例:Dir(bkFolder & "\*.xlsx")のパスの総文字数が半角240文字くらいを超過している
※これ対策はFSOでファイルを開く

投稿日時: 24/02/20 13:06:17
投稿者: りさこ

投稿者: WinArrow 様
 
ありがとうございます。
前置きしておりませんでした。当方マクロについてほとんど知識がないため、いただいた参考例をどこに代入すべきかすらわかりません。
 
冒頭の

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Title = "フォルダ選択"
        If .Show = True Then
            Dim bkFolder As String: bkFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

 
の部分を
  Dim FileName As Variant
  FileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*", _
                        MultiSelect:=True)
  If Not IsArray(FileName) Then
    Exit Sub
  End If

に置き換えれば良いのでしょうか?
 
やりたい事としては、Excelファイル50個ほどが格納されているフォルダを都度選択し、その中の「速報」というシートだけを収集したいのですが、置き換えてしまった場合、フォルダ選択は可能でしょうか?
[/code]

回答
投稿日時: 24/02/20 14:32:36
投稿者: simple

事実関係をもう少し教えてください。
・そのブックは手作業で開けますか?
・そのブックのパスに何か通常は用いないような文字が使われていませんか?
 (抽象的過ぎてわかりにくいですけど。)

回答
投稿日時: 24/02/20 14:41:19
投稿者: WinArrow

参考例への置き替えは、あとまわしにして、
各変数の確認はできましたか?
原因を特定する方がさきです。

投稿日時: 24/02/20 14:52:21
投稿者: りさこ

>エラーになったところで、黄色で止まているので、
>変数にカーソルを当てると、変数の値が表示されます。
 
これを知らなかったので大変参考になりました!
おかげでエラーの原因になっているファイル名を特定できました。
この1つのファイルだけをフォルダから除外したらマクロが実行できました。
 
ファイル名を具体的に記載したいのですが、関連する企業等が特定されてしまうので、そのまま記載することができません。
 
ファイル名をそのままペーストし、特定される文字だけを●に変えました。
●のところはひらがな・カタカナ・漢字といった普通の文字で、記号やスペースではありません。
●●●●●● ●●●●●●● 2.19~2.25.xlsx」です。
 
もしかしたら「~」がエラーの原因なのかもしれないと思って、「-」に変えたり、●以外を全て消したりして実行してみましたが、結果は同じでした。

回答
投稿日時: 24/02/20 16:26:19
投稿者: WinArrow

>●●●●●● ●●●●●●● 2.19~2.25.xlsx
「~」(チルダ)は、ファイル名として使用可能文字です。
「〜」(ウェーブダッシュ)は、ファイル名として使用不可文字です。
ですから、「〜」を使用したファイルは保存できないと思います。
●の文字の中に使用禁止文字があると思います。
見た目で判断すると落とし穴があるかもしれません。
 
ファイル名の中に、共通文字があると、Dir関数で指定することで防げるかもしれません。
 
 

回答
投稿日時: 24/02/20 17:22:30
投稿者: simple

ファイル名にUnicode文字を含む場合はDir関数は使わずに、
FSOを使ったほうがよいと思います。
# ちょっと外出しますので、また時間がとれれば書いて見ます。

回答
投稿日時: 24/02/20 18:44:39
投稿者: WinArrow

ファイル名にUnicode文字(環境依存文字など)が使用している場合、
Dir関数では「?」に変換されます。
これをworkbooks.Openに指定すると、実行時エラー(1004)になります。
FSOを使った例を紹介します。
 

Dim FN, F
    With CreateObject("Scripting.FilesystemObject")
        Set FN = .Getfolder(bkFolder & "\").Files
    End With
    Application.ScreenUpdating = False
    For Each F In FN
        If F.Name Like "*.xlsx" Then
            Set wbk = Workbooks.Open(F, UpdateLinks:=0)
    'この間にシート複写処理をいれる。
            wbk.Close False
        End If
    Next

 

トピックに返信