[[20200404130117]]　『削除された機能: パーツ内のデータの入力規則のエ』（あり）　ページの最後に飛ぶ

『削除された機能: パーツ内のデータの入力規則のエラー回避を知りたい』（あり）

マクロを実行すると統合したシートが「削除された機能: パーツ内のデータの入力規則のエラー回避」というエラーになってしまうのでエラー回避の方法があったら教えてください。

・基盤のブックにマクロが仕込まれていて、任意のフォルダを選択し、中のすべてのブックに下記のマクロを指示しています。
・フォルダ内にあるブックはすべて書式・表が同じですべて同じ作りで、一つだけまとめる用のセル内の(rowCnt, 77）が未入力のブックがあります。セル内の(rowCnt, 77）には入力規則でプルダウンで選択できるようになっています。

問題点。
・まとめたブックを確認で開くと表題のエラーが出て、コピーされた行だけプルダウンは残りますが選択項目が消えてしまいました。どうしたらいいのでしょうか？

Sub sample()

    Dim strPathName As String  'フォルダ名
    Dim strFileName As String  'ファイル名
    Dim strFullName As String
    Dim objWbk As Workbook      'シート
    Dim maxRow As Long
    Dim rowCnt As Long
    Dim myBook As Workbook

    rowCnt = 2
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            strPathName = .SelectedItems(1)
        End If
    End With

    If strPathName = "" Then Exit Sub
    strFileName = Dir(strPathName & "\*.xl*", vbNormal)
    If strFileName = "" Then
        MsgBox "このフォルダにはExcelワークブックは存在しません。", vbExclamation
        Exit Sub
    End If
        For Each myBook In Workbooks  'NOのブックを探す
        If myBook.Name Like "*NO*" Then
        myBook.Activate
        Exit For
        End If
        Next

    maxRow = myBook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row  
    Do While strFileName <> ""
        Dim wb As Workbook
        For Each wb In Workbooks
            If wb.Name = strFileName Then
                GoTo LoopLast
            End If
        Next wb
        strFullName = strPathName & "\" & strFileName
        Set objWbk = Workbooks.Open(Filename:=strFullName, UpdateLinks:=False)

 If objWbk.Worksheets(1).AutoFilterMode Then
    If objWbk.Worksheets(1).AutoFilter.FilterMode Then
       objWbk.Worksheets(1).ShowAllData
    End If
 End If

 For rowCnt = 2 To maxRow
     If objWbk.Worksheets(1).Cells(rowCnt, 68).Value <> "" Then 
        objWbk.Worksheets(1).Range(objWbk.Worksheets(1).Cells(rowCnt, 68), objWbk.Worksheets(1).Cells(rowCnt, 77)).Copy _
        myBook.Worksheets(1).Cells(rowCnt, 68)
     End If
 Next rowCnt

LoopLast:

        strFileName = Dir
    Loop    
    MsgBox "★完了"

 End Sub

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

 コードを見ても何だかよく分からないですが、
 要するに、入力規則がコピーじゃまともに成立しない設定になっているからなんじゃないですか？

 そうだとすると、どんな入力規則が設定されているか説明して頂かないと、
 第三者にはどうすればいいかなんて分からないです。

（半平太） 2020/04/04(土) 18:16

googleで「"削除された機能: パーツ内のデータの入力規則のエラー回避"」で検索すると

"削除された機能: パーツ内のデータの入力規則のエラー回避"との一致はありません。

って出ますが、エラーメッセージは正確ですか？

削除された機能: <文字列>　パーツ内のデータの入力規則

なら質問と回答が出ますが。

ついでにその質問と回答のアドレスを。

https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14120959639
https://qa.itmedia.co.jp/qa9524354.html

回答の内容としては、
・値のみを使用する
・入力規則の制限を越えていないか確認する
と言うことらしいです。

この場合だと、「まとめたブック」のみを開いて、入力規則が正常に入力できるか試してみては？
（2u） 2020/04/04(土) 20:54

半平太様　2u様
ご返信に気づかず申し訳ございませんでした。
お二方の仰る通り、削除された機能: <文字列>　パーツ内のデータの入力規則のエラーで、
「値のみを使用する」ことで解決できそうでした。
エラーが出ているシートはシート2に雛型があり、その項目がプルダウンで選択できるようになっています。マクロを実行すると選択肢が消えてしまう状況でございます。

そこで
For rowCnt = 2 To maxRow

     If objWbk.Worksheets(1).Cells(rowCnt, 68).Value <> "" Then 
        objWbk.Worksheets(1).Range(objWbk.Worksheets(1).Cells(rowCnt, 68), objWbk.Worksheets(1).Cells(rowCnt, 77)).Copy _
        myBook.Worksheets(1).Cells(rowCnt, 68)
     End If
 Next rowCnt

の部分のコピーメソッドを編集しなければならないのですが今ここでつまずいております。
もしまだこのページを拝見されている方がおられましたらご教授頂ければ幸いです。
（あり） 2020/04/10(金) 15:20

私だったら、エラーになる元のブックをコピーしておいてから、自動修復させて保存。元と修復後のブックをぞれぞれZIP形式にリネームし、どこが違っているかXMLファイル同士を比較しますね。

マクロ実行で必ずエラーになるようなら、自動修復で消された部分を手掛かりに、処理を見直してみてください。
（???） 2020/04/10(金) 16:01

???様
ありがとうございます！！
エラーは「値だけ貼り付け」でコピーをするとエラー回避ができました。
そのためコピーメソッドではなく、valueやPasteSpecialメソッドで
For rowCnt = 2 To maxRow

     If objWbk.Worksheets(1).Cells(rowCnt, 68).Value <> "" Then 
        objWbk.Worksheets(1).Range(objWbk.Worksheets(1).Cells(rowCnt, 68), objWbk.Worksheets(1).Cells(rowCnt, 77)).Copy _
        myBook.Worksheets(1).Cells(rowCnt, 68)
     End If
 Next rowCnt

の部分を編集しようと試みています。が、上手く構文を考えられておりません。。
（あり） 2020/04/10(金) 16:41

コピペで駄目なのは、元ブックへのリンクになってしまうからでしょうね。
試していませんが、値貼り付けで良いなら、以下とか。

    With objWbk.Worksheets(1)
        For rowCnt = 2 To maxRow
            If .Cells(rowCnt, 68).Value <> "" Then
                .Range(.Cells(rowCnt, 68), .Cells(rowCnt, 77)).Copy
                myBook.Worksheets(1).Cells(rowCnt, 68).PasteSpecial Paste:=xlPasteValues
            End If
        Next rowCnt
    End With
（???） 2020/04/10(金) 16:56

再度ご返信ありがとうございます。
CellsとRangeの使い分け、PasteSpecial Paste:=xlPasteValuesの部分の構文の配列（？）とても勉強になりました。そして、理想の作業が出来ました。ありがとうございました！！
今回、上げさせていただいた構文をしっかり読み返しシンプルに作り替えれるまで繰り返し確認していきたいと思います、本当にありがとうございました。
（あり） 2020/04/11(土) 16:34

コメント返信：

[ 一覧(最新更新順) ]

[[20200404130117]] 『削除された機能: パーツ内のデータの入力規則のエ』（あり） ページの最後に飛ぶ

[[20200404130117]]　『削除された機能: パーツ内のデータの入力規則のエ』（あり）　ページの最後に飛ぶ