HOME > Q&A > Excel （VBA）

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

 
(Windows 11 Home : Excel 2019)
マクロの修正について（3シート除外したい）
投稿日時: 23/11/17 13:05:01
投稿者: りさこ

下記マクロにおいて、★のつけてある2箇所
If WS.Name <> "集約" And WS.Name <> "貼付用" Then
によって2シートを処理から除外しているのですが、これを
 
If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "完了" Then
に書き換えて3シート除外しようとすると、
 
2箇所目の書き換え部分（'貼付用のデータを作成する。-----------）
If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "完了" Then
 
のほうで止まってしまいます。
シートの指定を１つ増やしただけですが、どこかほかに修正しなくては
いけない場所があるのでしょうか。
教えてください。
 
====================================================================
 
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 <> "貼付用" Then　★
            WS.Range("A1:D1,A2:N2,A15:D15,A16:N16").UnMerge
' For Each ce In ws.Range("A2:N2,A16:N16")
            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("A:H").Columns.AutoFit
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
'全てのシートのA1を選択して終わる　--------------------------------------------------------
 
  Dim WB As Workbook
  Set WB = ActiveWorkbook
   
  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 <> "貼付用" 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
     
    WB.Worksheets(1).Activate
    Range("C2:C1000").NumberFormatLocal = "m月d日(aaa)" '曜日を追加
     
        With ActiveSheet.AutoFilter.Sort
        With .SortFields
            .Clear 'ソートキーをクリア
            '昇順にソート
            .Add Key:=Range("A1"), Order:=xlAscending
        End With
        .Apply '設定を適用する
    End With
     
End Sub
 
 
回答
投稿日時: 23/11/17 13:26:47
投稿者: simple

> 止まってしまいます。
その行でエラーになるんですか？
そうなら、その時のエラーメッセージを省略せずに示してもらえますか？

投稿日時: 23/11/17 13:38:01
投稿者: りさこ

実行時エラー '91!:
オブジェクト変数またはWithブロック変数が設定されていません。
 
となり、そのMsgBoxで「デバッグ」を押すと、２つめの
If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "完了" Then
が黄色くなっているという状態です。
 
 

simple さんの引用:
> 止まってしまいます。
その行でエラーになるんですか？
そうなら、その時のエラーメッセージを省略せずに示してもらえますか？

回答
投稿日時: 23/11/17 14:31:27
投稿者: simple

回答ありがとうございます。
二つ目ということは、本来shを使うべきところをWSを使ってしまっているとかですか？

回答
投稿日時: 23/11/17 14:54:58
投稿者: Suzu

simple さんの引用:
回答ありがとうございます。
二つ目ということは、本来shを使うべきところをWSを使ってしまっているとかですか？

 
 
現状提示 コード
 
引用:
Dim sh
    cnt = 2
    For Each sh In Worksheets
        If sh.Name <> "集約" And sh.Name <> "貼付用" Then　★

 
に対し、
 
sh に対し判定を行っていますから 
        If sh.Name <> "集約" And sh.Name <> "貼付用" And sh.Name <> "完了" Then

 
とすべき所を、質問文の様に
 
引用:
2箇所目の書き換え部分（'貼付用のデータを作成する。-----------）
If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "完了" Then

 
sh ではなく、WS を使用していると言う事。
 
WSは、1回目のループで使用しており
そこを抜けていますから、既に Nothing になっている状態です。
 
 
同じ オブジェクトを扱うのに、別な変数を宣言し、使用しなくとも良いでしょう。
 
    For Each sh In Worksheets
        If sh.Name <> "集約" And sh.Name <> "貼付用" Then　★
            lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
 
を、
    For Each WS In Worksheets
        If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "完了" Then
            lastRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
　　　　　　：
　　　　　以下 sh を WS に書き換え
 
を行っても良いでしょう。
 
WorkSheet オブジェクトのみならず、WorkBook オブジェクトも同様ですね。
回答
投稿日時: 23/11/17 16:49:00
投稿者: WinArrow

コードの以外でのアドバイス
 
シートを除外る方法よりも、決め打ちの方が無難なのではと思います。
特に２つ目の除外部分は・・・・
For Each sh In worksheets
    if sh.Name <> "・・・・・については、貼付用シートに複写しているから、
　　複写元シートが複数存在することは考えにくいです。
 
それから、ループして行単位で複写していますが、
行ではなく、セル範囲で複写すれば、コードとしては、１行で済みます。
決め打ちするならば、For 〜 Next も必要ないでしょう。
 
　　

投稿日時: 23/11/22 09:45:32
投稿者: りさこ

日数が空いてしまい、回答いただいた方、申し訳ありません。
あれからご提案いただいたものをいろいろ試したみたのですが、どうしてもうまくいかなくて…私の知識がなさすぎて、結局のところどこをどう修正したら良いのかがわからずじまいで(;´Д｀)
もしよろしければ、丸ごとを編集していただけないでしょうか。
 

引用:
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 <> "貼付用" Then　★
            WS.Range("A1:D1,A2:N2,A15:D15,A16:N16").UnMerge
' For Each ce In ws.Range("A2:N2,A16:N16")
            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("A:H").Columns.AutoFit
        End If
    Next
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
  
'全てのシートのA1を選択して終わる　--------------------------------------------------------
  
  Dim WB As Workbook
  Set WB = ActiveWorkbook
    
  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 <> "貼付用" 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
      
    WB.Worksheets(1).Activate
    Range("C2:C1000").NumberFormatLocal = "m月d日(aaa)" '曜日を追加
      
        With ActiveSheet.AutoFilter.Sort
        With .SortFields
            .Clear 'ソートキーをクリア
            '昇順にソート
            .Add Key:=Range("A1"), Order:=xlAscending
        End With
        .Apply '設定を適用する
    End With
      
End Sub
回答
投稿日時: 23/11/22 11:48:06
投稿者: simple

早速ご返事いただきました。（これで遠足終われますかね）
 
メモしておきます。
 
シート変数の話は、ドンマイ ということですね。
(1)シートの指定のところは、今の案のままで問題ないと思います。
   読み込んだブックの名前(の左30文字）ということですから、予めコードで特定することは
   できません。
(2)コピー貼り付けの箇所 

'   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
のところは、 
  lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
  sh.Range("A1:H" & lastRow).Copy Destination:=貼付sh.Cells(Rows.cnt, "B").End(xlUp).Offset(1)
のように書くとセル範囲を纏めてコピーペイストできます。
 
その他のところは詳細見ておりません。
Set WB = ActiveWorkbook
より
Set WB = ThisWorkbook
が明確だと思いますし、 
For Each sh In WB.Worksheets
のように統一し、念のためブックを指定したほうが可読性は高いかもしれません、
と言った事柄がありますが、本筋の話ではありません。
 
不明点があれば引き続きコメントしてください。

回答
投稿日時: 23/11/22 11:54:51
投稿者: Suzu

引用:
提案いただいたものをいろいろ試したみたのですが、どうしてもうまくいかなくて…

 
何をどう試されて、うまくいかない のでしょうか？
 
提示されたコードは、質問時のコードとどこか変わっているのでしょうか？
 
先の回答の意図としては、
    For Each sh In Worksheets
        If sh.Name <> "集約" And sh.Name <> "貼付用" Then
を
 
    For Each sh In Worksheets
        If sh.Name <> "集約" And sh.Name <> "貼付用" And sh.Name <> "完了" Then
 
としなきゃいけないのに、
 
質問文では
        If WS.Name <> "集約" And WS.Name <> "貼付用" And WS.Name <> "完了" Then
 
としており、
sh とすべき を WS としているのはないの？ と言う事。
 
 
実際には、sh に しているのだけど ・・ と言うなら
 
1. 具体的に こんな事を行いました。
2. 結果 こうでした。
3. 目的とここがちがいます。
　 こんなエラーになりました。
 
の様に、具体的に 動作を再現できる情報を 提示する様にしましょう。
 
 
わからない と ひとことでかたづけていらっしゃいますが、
ご自身で、コードがどんな動きをしているのか分からないと
希望通りに動かす為の確認ができませんよ。
  
どこに問題があるのか を 明らかにする方法として
各変数 に どんな 値・オブジェクトが 保存されているか
　（ワークシート オブジェクトなら、複数のワークシートが あると思いますが
　　 そのうちどのワークシートに対し 操作をおこなっているのか）
 を 確認する必要があります
  
その方法はご存じでしょうか？
  
「VBA デバック方法」 をキーワードにWEB検索を行うと方法についての情報が得られますよ。
投稿日時: 23/11/22 15:03:35
投稿者: りさこ

できました！！！！
ありがとうございました！！
感謝いたします！！！！
回答
投稿日時: 23/12/01 17:26:36
投稿者: WinArrow

解決したならば、
スレを閉じてくださいね！！

トピックに返信