質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

90.34%

  • VBScript

    238questions

    VBScript(Visual Basic Scripting Edition)はMicrosftが開発したスクリプト言語であり、Visual Basicのサブセットです。

【VBS】Excelセルコピーが画像(?)になってしまう

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 562

irohamaru

score 5

以下のVBScriptで、「コピー元のExcelファイルの指定セルの文字列を、コピー先のExcelファイルにペーストする」という処理を実現しようと思っています。

<フォルダ構成>
イメージ説明

コピー元フォルダの中にコピー対象のExcelファイルを配置
イメージ説明

テンプレートフォルダの中にペーストするExcelファイルを配置。
コピー元フォルダに配置されたExcelファイルの数の分複製される。
イメージ説明

実行したところ、以下のようにコピーしたセルが画像のような形でペーストされており、意図した結果でないため困っています。

イメージ説明

コピーの仕方が悪いのか、ペーストの仕方が悪いのか、
どなたか原因が分かる方がいらっしゃったらご教示願います。

Option Explicit

' ======================================================================================
' 変数定義
' 
' ======================================================================================

Dim objFSO             ' FileSystemObject
Dim baseFolder         ' 作業フォルダパス
Dim copyFolder         ' コピー元フォルダパス
Dim pasteFolder        ' コピー先フォルダパス
Dim copySheetName      ' コピー元シート名
Dim copyRange          ' コピー元セル範囲

Dim pasteSheetName     ' コピー先シート名

Dim templateFileName   ' テンプレートファイル名
Dim templateFolder     ' テンプレートファイルが配置されたフォルダパス

' ======================================================================================
' パラメータ設定(環境に合わせて定義すること)
' 
' ======================================================================================

copySheetName = "フォーマット" ' コピー元シート名
copyRange = "[B6:E6],[B9:D10],[G7:AJ106]" ' コピー元セル範囲(複数の範囲指定⇒(例)"[A1:A2],[B1,B2]")

pasteSheetName = "フォーマット" ' コピー先シート名

templateFileName = "template.xlsx"


' ======================================================================================
' EXCELコピー&ペースト
'
' ======================================================================================
' フォルダパス設定
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Err.Number = 0 Then
    Dim currentDir
    currentDir = objFSO.getParentFolderName(WScript.ScriptFullName)
    copyFolder = currentDir & "\" & "コピー元"
    pasteFolder = currentDir & "\" & "コピー先"
    templateFolder = currentDir & "\" & "テンプレート"
Else
    WScript.Echo "エラーが発生したため終了します。"
    WScript.Quit
End If

' コピー元セル範囲をリスト化
Dim RangeList
RangeList = Split(copyRange, ",")

'エラー情報をクリアする。
Err.Clear


' フォルダ内(サブフォルダも含む)でループしてコピー元ファイルを取得
ShowSubfolders objFSO.GetFolder(copyFolder)

Dim File
Sub ShowSubFolders(Folder)
    For Each File in Folder.Files 'フォルダ内のファイルを列挙する
        'EXCELファイルか判定
        Dim ext
        ext = objFSO.GetExtensionName(File.Name)

        If ext = "xlsx" Or ext = "xlsm" Then
            ' 変数定義
            Dim copyFilePath, pasteFilePath, templateFilePath, copyExcelObj, pasteExcelObj
            Dim copyFileObj, pasteFileObj, copySheetObj, pasteSheetObj

            templateFilePath = templateFolder & "\" & templateFileName
            copyFilePath = copyFolder & "\" & File.Name
            pasteFilePath = pasteFolder & "\" & File.Name

            ' コピー元と同じファイル名でコピー先ファイルを生成
            objFSO.CopyFile templateFilePath, pasteFilePath, True

            ' コピーエラー発生時は終了する
            If Err.Number <> 0 Then
                Set File = Nothing
                Set objFSO = Nothing

                WScript.Echo "テンプレートコピーでエラーが発生したため終了します。"
                WScript.Quit
            End If

            ' コピー元ファイルを開く
            Set copyExcelObj = WScript.CreateObject("Excel.Application")
            Set copyFileObj = copyExcelObj.Workbooks.Open(copyFilePath)
            Set copySheetObj = copyFileObj.Worksheets(copySheetName)


            ' コピー先ファイルを開く
            Set pasteExcelObj = WScript.CreateObject("Excel.Application")
            Set pasteFileObj = pasteExcelObj.Workbooks.Open(pasteFilePath)
            Set pasteSheetObj = pasteFileObj.Worksheets(pasteSheetName)

            pasteSheetObj.Activate

            ' コピー対象セル範囲を取得(リストで保持)
            Dim RangeVal
            For Each RangeVal in RangeList
                RangeVal = Replace(Replace(RangeVal, "[", ""), "]", "")

                copySheetObj.Range(RangeVal).Copy

                ' コピー先ファイルにペースト
                'pasteSheetObj.Range("A1").Select
                ' -4104
                pasteSheetObj.Range(RangeVal).PasteSpecial(-4104)

            Next

            pasteFileObj.Save
            pasteFileObj.Close

            copyExcelObj.Quit
            pasteExcelObj.Quit

        Else
            WScript.Echo "テンプレートコピーに失敗しました。"
            WScript.Quit
        End If
    Next

    Dim Subfolder
    For Each Subfolder in Folder.SubFolders 'フォルダ内のフォルダを列挙する
        ShowSubFolders Subfolder '再帰呼び出し
    Next
End Sub

WScript.Echo "テストデータコピーが完了しました。"
WScript.Quit

Set copyExcelObj = Nothing
Set copyFileObj = Nothing
Set copySheetObj = Nothing

Set pasteExcelObj = Nothing
Set pasteFileObj = Nothing
Set pasteSheetObj = Nothing

Set File = Nothing
Set objFSO = Nothing

Set Subfolder = Nothing
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

回答 1

checkベストアンサー

+1

色々調べてみましたけど原因不明です。
値のみのコピーで良いならPasteSpecial(-4163)とすることで可能です。
ただし、以下の警告が出てしまいます。

貼り付けようとしているデータと選択した領域のサイズと異なります。貼り付けますか?

こちらも理由はわかりませんでした。
G7:AJ106のときのみ出るので、範囲が広いと出るのかもしれません。
こちらの仮対処としては、貼り付け時の範囲を左上のみを指定することで回避できました。

rs = Split(RangeVal, ":")
pasteSheetObj.Range(rs(0)).PasteSpecial(-4163)

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2018/06/26 17:31

    わざわざ調べてくださり、ありがとうございます!
    根本的な原因は気になりますが、とりあえず回避策が見つかっただけでも感謝です。
    ありがとうございました!

    キャンセル

同じタグがついた質問を見る

  • VBScript

    238questions

    VBScript(Visual Basic Scripting Edition)はMicrosftが開発したスクリプト言語であり、Visual Basicのサブセットです。