none
Excel 2016 , Excel 2013 のVBAでコピー&ペーストすると、「問題が発生したため、。。」が表示されてしまいます。 RRS feed

  • 質問


  • はじめまして。Excel 2016 , Excel 2013 のVBAを使い以下のプログラムを実行すると上記のダイアログが表示されます。
    OSは、Win10のHomeです。
    Excel 2016(64bit版) , Excel 2013(32bit版)は、更新は最新(2016/11/12時点)になっております。

    原因が分からず困っております。どなたかご教授願います。


    どうやら以下の部分が問題がありそうなのですが、対処が分かりません。

            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy Destination _
                                            :=ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add)

    または、

            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy
            ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False


    ここから、VBAプログラムです。

    Private Sub copy_proc()

        Dim copy_addr1 As String
        Dim copy_addr2 As String
        Dim past_addr As String
        Dim row As Long
       
        Const Sheet1_Name = "Sheet1"

        For row = 1 To 3000
            ThisWorkbook.Worksheets(Sheet1_Name).Cells(row, 1) = row
        Next


        For row = 1 To 3000
            copy_addr1 = Cells(row, 1).Address & ":" & Cells(row, 1).Address
            past_addr = Cells(row, 2).Address
            
            Call CopyAndPaste_cells(Sheet1_Name, copy_addr1, Sheet1_Name, past_addr, 3)
        Next
       
    End Sub


    Option Explicit

    '*********************************************************
    ' ミリ秒単位を扱う
    '*********************************************************
    #If VBA7 And Win64 Then
        Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
    #Else
        Private Declare Function GetTickCount Lib "kernel32" () As Long
    #End If

    #If VBA7 And Win64 Then
        Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
    #Else
        Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    #End If


    '*********************************************************
    '    セルのコピー&ペースト
    '*********************************************************
    Public Function CopyAndPaste_cells(copy_SheetName As String, copy_add As String, paste_SheetName As String, paste_add As String, copy_Type As Integer) As Boolean
        
        On Error GoTo ErrorTrap_CopyAndPaste_cells
       
        '①各種の確認ダイアログを非表示
        Application.DisplayAlerts = False
        Excel.Application.CutCopyMode = True
        Call WaiteMillSec_03(50)
       
        If (copy_Type = 1) Then
            ' <速度遅い> クリップボードを経由してセルのデータだけをコピペする。
            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy
            ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add).PasteSpecial Paste:=xlPasteValues
        ElseIf (copy_Type = 2) Then
            ' <速度速い> クリップボードを経由せずセルの全情報をコピペする。
            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy Destination _
                                            :=ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add)
        ElseIf (copy_Type = 3) Then
            ' <速度遅い> クリップボードを経由してセルの全情報をコピペする。
            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy
            ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
        Call WaiteMillSec_03(50)
        Excel.Application.CutCopyMode = False     ' クリップボードにコピーされたセルの内容を削除する

        '③各種の確認ダイアログを表示
        Application.DisplayAlerts = True

        CopyAndPaste_cells = True
        Exit Function

    ErrorTrap_CopyAndPaste_cells:
        CopyAndPaste_cells = False

    End Function

    '*********************************************************
    '   ウェイト処理(DoEvents 発行)
    '*********************************************************
    Public Sub WaiteMillSec_03(ByVal Milisecond As Double)
       
        Dim t_out As Double

        Const SLEEP_MSEC = 1

        t_out = GetTickCount + Milisecond
        While t_out > GetTickCount
            DoEvents
            Sleep SLEEP_MSEC
        Wend
       
     End Sub

    追記情報です。

    「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示されても、
    記載致しましたプログラムは動作し続けます」。
    また、一度、「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示されてから、
    もう一度、同じプログラムを実行すると「問題が発生したため、このフォルダーを表示できません。」が表示されます。
    しかし、OSを再起動し同じプログラムを実行すると「問題が発生したため、このフォルダーを表示できません。」が表示されます。


    以下の2パターンで実行し比べても同じ結果になります。
            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy Destination _
                                            :=ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add)
    または
            ThisWorkbook.Worksheets(copy_SheetName).Range(copy_add).Copy
            ThisWorkbook.Worksheets(paste_SheetName).Range(paste_add).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

    また、ウェイト処理を次の様に修正しましたが、同じ結果でした。

    結果は、同じでした。

    '*********************************************************
    '   ウェイト処理(DoEvents 発行)
    '*********************************************************
    Public Sub WaiteMillSec_03(ByVal Milisecond As Double)
       
        Dim t_out As Double
        Dim k As Integer
       
        Const SLEEP_MSEC = 50

        t_out = GetTickCount + Milisecond
        While t_out > GetTickCount
            For k = 1 To SLEEP_MSEC
                DoEvents
            Next
            Sleep SLEEP_MSEC
        Wend
       
     End Sub


    以上、宜しくお願い致します。

    2016年11月13日 10:45

すべての返信

  • 「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示される件で、
    情報を追記致します。

    以下のプログラムを試してみました。
    「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログは、「GetInputState」APIでは検知できませんでした。

    どなたかご教授お願い致します。


    #If VBA7 And Win64 Then
        Public Declare PtrSafe Function GetInputState Lib "USER32" () As Long
    #Else
        Public Declare Function GetInputState Lib "USER32" () As Long
    #End If

    '****************************************************************************************************************************************************************************************************************
    '   ウェイト処理(DoEvents 発行)
    '****************************************************************************************************************************************************************************************************************
    Public Sub WaiteMillSec_00(ByVal Milisecond As Double)
       
        Dim t_out As Double

        Const SLEEP_MSEC = 20

        t_out = GetTickCount + Milisecond

        Do
            If (GetTickCount > t_out) Then
                Exit Do
            End If
           
            If (GetInputState() <> 0) Then
                'Debug.Print Time
                DoEvents
            Else
           
            End If
        Loop
        Sleep SLEEP_MSEC
       
    End Sub

    以上、よろしくお願い致します。

    2016年11月14日 1:52
  • お世話になります。追記情報を記載させて頂きます。
    次のプログラムの場合、CopyAndPaste_cells()関数内でCall WaiteMillSec_03(500)とすることで、「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示されなくなりました。

    Private Sub copy_proc()

        Dim copy_addr1 As String
        Dim copy_addr2 As String
        Dim past_addr As String
        Dim row As Long
       
        Const Sheet1_Name = "Sheet1"

        For row = 1 To 3000
            ThisWorkbook.Worksheets(Sheet1_Name).Cells(row, 1) = row
        Next


        For row = 1 To 3000
            copy_addr1 = Cells(row, 1).Address & ":" & Cells(row, 1).Address
            past_addr = Cells(row, 2).Address
            
            Call CopyAndPaste_cells(Sheet1_Name, copy_addr1, Sheet1_Name, past_addr, 3)
        Next
       
    End Sub

    '*********************************************************
    '   ウェイト処理(DoEvents 発行)
    '*********************************************************
    Public Sub WaiteMillSec_03(ByVal Milisecond As Double)
       
        Dim t_out As Double

        Const SLEEP_MSEC = 1

        t_out = GetTickCount + Milisecond
        While t_out > GetTickCount
            DoEvents
            Sleep SLEEP_MSEC
        Wend
       
     End Sub

    上記の場合、1個のセルのコピーです。
    試しに、288セル×10段=2880個のセルを1000回コピーした場合、Call WaiteMillSec_03(500)で実験してみました。
    結果は、「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示てしまいました。
    DoEventsの最適となる発生回数が、まったく分かりません。

    OS側でどの様な状態になって、「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示されるのかお手上げ状態で御座います。

    何卒、ご教授の程、宜しくお願い致します。

    2016年11月15日 10:10
  • OS側でどの様な状態になって、「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアログが表示されるのかお手上げ状態で御座います。

    当方 2013 環境では再現できませんでした(Office 365 ではないですが)。
    「クリップボードにアクセスできません。」のエラーならばともかく、「このフォルダーを表示できません。」は奇妙ですね。

    何故フォルダーなのか分かりませんが、たとえば下記のような可能性は考えられないでしょうか。

    • OneDrive フォルダーで、同期処理に失敗している。
    • カレントフォルダーが、現在アクセスできない場所(切断されたネットワークなど)になっている
    • ユーザー設定が破損している(代替スタートアップ フォルダーに余計なファイルがあるなど)
    • セキュリティ対策ソフトが並行稼動しており、それが悪影響を及ぼしている。
    • ディスク上に破損したファイルまたはフォルダが存在している。

    Windows 10上に新しいローカル アカウントを作成し、その新アカウント上で実行させてみると、異なる結果になるかも知れません。あとはOneDrive の同期に関する問題とか。

    2016年11月23日 0:36
  • 貴重なご意見有難うございます。

    可能性的に「•セキュリティ対策ソフトが並行稼動しており、それが悪影響を及ぼしている。」が色濃いと思われます。

    技法仕様は、小さなブロック単位でコピー&ペーストするものでしたが、解決策がない為、大きなブロック単位でコピー&
    ペーストする様に技法を変更しました。

    テンポラリーシートに全情報をコピーし、大きなブロック単位でコピー&ペーストしてデータを編集成形し、元のシート
    にテンポラリーシートをコピーする技法に変更致しました。
    その結果、スループットが向上し、「問題が発生したため、このフォルダーを表示できません。」ポップアップダイアロ
    グが表示されなくなりました。

    本当に、これで「問題の根本が解決された。」と思っておりませんが、何とかうまいこと対応出来たと思っております。

    自分のスキルでは、複雑で難しすぎて「•セキュリティ対策ソフトが並行稼動しており、それが悪影響を及ぼしている。」は
    解決出来ないと思えてなりません。

    ご教授有難う御座いました。

    2016年11月23日 3:02
  • 第三者の方からアドバイスを頂きました、

    今まで、Declare宣言をModuleで行っておりました。
    Declare宣言をSheetで行い実験してみました。


    #If VBA7 And Win64 Then
         Private Declare PtrSafe Function GetTickCount Lib "kernel32" Alias "GetTickCount64" () As LongLong
     #Else
         Private Declare Function GetTickCount Lib "kernel32" () As Long
     #End If

    #If VBA7 And Win64 Then
         Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
     #Else
         Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
     #End If

    不思議です。「問題が発生したため、このフォルダーを表示できません。」がまったく表示されなくなりました。


    Declare宣言をModuleで行った場合と、Sheetで行った場合どの様な違いがあるのでしょうか。
    推測ですが、Declare宣言の認識検知速度の違いが影響しているのでしょうか。
    正直、訳が分かりません。

    ご教授の程、宜しくお願い致します。

    2016年11月23日 13:23