プロが教える店舗&オフィスのセキュリティ対策術

以前、「複数ブックのシートを一つのブックにコピーする」VBAを教えていただきました。

そこで、誠に恐縮なのですが、下記を追加するにはどのようにすればよいのでしょうか?
1、コピー元とのグラフのリンクを解除する。
   数式のリンクは解除されているので、恐らくグラフのリンクが解除されていない。毎回、編集→リンクの設定で解除している。
2、シート名をセルB2の5文字目以降にしたい。
3、1つのセルに255文字以上入力されている、以降の文字がコピーしない現象を回避。
   シートのコピーをすると、255文字以降がコピーされない??
   セルを範囲選択してコピーした場合は、コピーできる。
4、最後に「Sheet1」を削除


下記が現在のVBAです。
Sub Consolid03()
Dim mb As Workbook, wb As Workbook
Dim myfdr As String, fname As String, n As Integer
Application.ScreenUpdating = False '画面更新を一時停止
Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
myfdr = ThisWorkbook.Path
fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
Do Until fname = Empty '全て検索
If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
wb.Close (False) '有無を言わずに保存せず閉じる
mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除
For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に
If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば
c.Value = c.Value '値に変更
End If
Next
mb.Sheets(mb.Sheets.Count).Protect Password:="9" 'パスワード保護
n = n + 1 'ブック数をカウント
End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す
Application.ScreenUpdating = True '画面更新一時停止を解除
MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _
+ Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _
+ Chr(&HD) + Chr(&HA) + "" _
+ Chr(&HD) + Chr(&HA) + "取りこんだシートにパスワード保護もかけておきましたよ。", , "( ̄ー ̄)v "
End Sub

以上、ご教示願います。。。

A 回答 (4件)

違うシートのセルB2ということはないですか?



ws.Name = Mid(ws.Range("B2").Value, 5)
上記で、コピー追加したシートのセルB2のデータを切り取ってシート名にしています。
それで合っているなら、セルB2に正しくデータが入力されているかどうか確認してください。

正しく入力されているようなら、1行上に
MsgBox Mid(ws.Range("B2").Value, 5)
を入れてマクロを実行してみてください。
どんな答えが返ってきますか?
    • good
    • 0
この回答へのお礼

xls88さん、何度もありがとうございます。
原因がわかりました。B2に制御文字「:」と「/」が入っていました。
できれば、「:」と「/」は、削除したくないのですが。。。
全部削除しないと無理なのでしょうか?

お礼日時:2008/09/12 11:57

>原因がわかりました。

B2に制御文字「:」と「/」が入っていました。
>できれば、「:」と「/」は、削除したくないのですが。。。
それは無理ということではないでしょうか。
何故、削除したくないのですか?
たとえ事情があるにしても、Excelさんが承知するはずがないです。
消去するなら
ws.Name = Replace(Replace(Mid(ws.Range("B15").Value, 5), ":", ""), "/", "")
置き換えるなら
ws.Name = Replace(Replace(Mid(ws.Range("B15").Value, 5), ":", "☆"), "/", "★")
としてください。

>グラフのリンクの件
>「自」ブックの中で、他シートを参照し、グラフを表示しています。
コピー先での「元のデータ」はどうなるのですか?
「元のデータ」が用意されていて、リンクを切れば「元のデータ」が切り替わるようになっているのですか?
    • good
    • 0

dorikinさんオリジナルマクロに組み込んでみました。


追加したところは、★印でコメントしてあります。
動作は未確認です。

ひとつ気になるところがあります。
wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
開いたブックwbのActiveSheetをCopyしていますが
ActiveSheetが一定で決まっているなら問題ないです。
しかし、複数のシートが存在する場合、目的のシートがActiveSheetである保証はないと思います。
拙くはないですか?

Sub Consolid03_test()
  Dim mb As Workbook, wb As Workbook
  Dim myfdr As String, fname As String, n As Integer
  Dim ws As Worksheet '★(1)追加シートの変数

  Application.ScreenUpdating = False '画面更新を一時停止
  Set mb = ThisWorkbook 'このコピー先ブックをmbとする。
  myfdr = ThisWorkbook.Path
  fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索
  Do Until fname = Empty '全て検索
    If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ
      Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。
      '★↓ここまずくないですか?
      wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く
      wb.Close (False) '有無を言わずに保存せず閉じる
      
      Set ws = mb.Sheets(mb.Sheets.Count) '★(2)追加したシート
      ws.Name = Mid(ws.Range("B2").Value, 5) '★(3)追加したシートの名前変更
      ws.Unprotect Password:="9" '★(4)パスワード解除
      'mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除
      
      For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に
        If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば
          c.Value = c.Value '値に変更
        End If
      Next
      ws.Protect Password:="9" '★(5)パスワード保護
      'mb.Sheets(mb.Sheets.Count).Protect Password:="9" 'パスワード保護

      n = n + 1 'ブック数をカウント
    End If
    fname = Dir 'フォルダ内の次のExcelブックを検索
  Loop '繰り返す
  
  mb.Sheets("Sheet1").Delete '★(6)最後にSheet1を削除
  
  Application.ScreenUpdating = True '画面更新一時停止を解除
  MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _
    + Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _
    + Chr(&HD) + Chr(&HA) + "" _
    + Chr(&HD) + Chr(&HA) + "取りこんだシートにパスワード保護もかけておきましたよ。", , "( ̄ー ̄)v "
End Sub
    • good
    • 0
この回答へのお礼

xls88さん、ご回答ありがとうございます。
上記をコピーして実行してみたのですが、「実行時エラー1004 シートまたはグラフの名前が正しくありません」とエラーになります。
デバックをみると、
「ws.Name = Mid(ws.Range("B2").Value, 5) '★(3)追加したシートの名前変更」
の部分が黄色くなっています。
この1行を削除すると実行できるのですが、シート名をセルB2の5文字目以降にはなっていません。。。(Sheet1は削除になっていました)

「★↓ここまずくないですか?」の部分の件
シートは複数あります。開いた時に目的のシートが表示されるよう保存をしてから、マクロ実行しています。目的のシートはマクロ実行のたびに変わるのですが、シート名は全てのブックで共通です。シート名を指定してからマクロをかけられれば、それが一番よいのですが。。。

グラフのリンクの件
「自」ブックの中で、他シートを参照し、グラフを表示しています。
マクロの実行をするのと、「他」のブックとのリンクになってしまいます。
このリンクを解除するのは難しいのでしょうか?

お礼日時:2008/09/10 13:02

>1、コピー元とのグラフのリンクを解除する。


>数式のリンクは解除されているので、恐らくグラフのリンクが解除されていない。
>毎回、編集→リンクの設定で解除している。

グラフの場所はどこになっていますか?
(1)データとグラフが同じシートにあるなら
シートそのものをコピーしているので、グラフと元のブックとの関係は遮断されているはずです。
(2)データとグラフが異なるシートにあるなら
データシートとグラフシートを、同時に同じブックにコピーすればグラフと元のブックとの関係は遮断されます。
(3)データとグラフが異なるシートにあり、グラフシートのみコピーした場合
グラフの各系列毎に、SERIES関数を値に置き換えればよいと思います。

>2、シート名をセルB2の5文字目以降にしたい。
Activesheet.Name = Mid(Worksheets("Sheet1").Range("B15").Value, 5)

>3、1つのセルに255文字以上入力されている、以降の文字がコピーしない現象を回避。
パスします。

>4、最後に「Sheet1」を削除
Workbooks("Knet1グラフ5.xlsm").Sheets("Sheet1").Delete

この回答への補足

制御文字を取り除くことに成功しました。
ありがとうございました。

補足日時:2008/09/13 07:51
    • good
    • 0
この回答へのお礼

ありがとうございます。
ご回答をいただいてから上記をコピーして実行してみたのですが、エラーになります。
このマクロは1つのフォルダの中に複数のブックを入れ(マクロ入りブックも含む)、マクロ入りブックのみ開き、マクロ実行すろと全てのブックのシートがマクロ入りブックのシートに追加されるマクロです。

具体的には、どの行に(そのまま?)コピーすればよいのでしょうか?
マクロ初心者で申し訳ありません。。。
よろしければ、ご教示願います。

お礼日時:2008/09/09 08:48

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!