• ベストアンサー
  • 暇なときにでも

エクセルVBAでBOOKを開く際の処理

エクセルVBAでBOOKを開く際の処理 エクセル2000です。 VBAで特定のフォルダー内のBOOKを開き、1枚目のシートSheets(1)のデータを読み込んで別BOOK(マクロを記載したBOOK)にコピペしたら保存せず閉じるコードを下記のように書きました。(かなり簡略化しましたが) これで作動するのですが、万一、そのフォルダー内のBOOKが開いていても1枚目のシートのデータを読み込み後、閉じられてしまいます。 BOOKが開いていれば、その開いていたBOOKは閉じず、先に進むようにするにはどのように直せばいいでしょうか? Sub TEST01()   Dim mb As Workbook, wb As Workbook   Dim myfd As String, fnme As String, ans As Byte, i As Long      ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね?", vbYesNo + vbQuestion, "( ̄∇ ̄) ? ")   If ans = vbNo Then     MsgBox "それじゃだめです。", vbCritical, "Σ( ̄ロ ̄lll)"     Exit Sub   End If      Set mb = ThisWorkbook   myfd = mb.Path   fnme = Dir(myfd & "\*.xls")      Do Until fnme = Empty     If fnme <> mb.Name Then       Set wb = Workbooks.Open(myfd & "\" & fnme)       i = i + 1       mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")       wb.Close (False) '保存せずに閉じる     End If     fnme = Dir   Loop        Set mb = Nothing   Set wb = Nothing   MsgBox i End Sub

共感・応援の気持ちを伝えよう!

  • 回答数5
  • 閲覧数487
  • ありがとう数8

質問者が選んだベストアンサー

  • ベストアンサー
  • 回答No.4
  • Wendy02
  • ベストアンサー率57% (3570/6232)

ほんのちょっとの所を直しました。基本的には、単に付け足すだけです。変えた部分は、私の知っている書法の一部分です。 '// Sub Test01r()  Dim mb As Workbook, wb As Workbook  Dim myFd As String, Fnme As String, ans As Integer, i As Long  Dim flg As Boolean  ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね?", vbYesNo + vbQuestion, "( ̄∇ ̄) ? ")  If ans = vbNo Then   MsgBox "それじゃだめです。", vbCritical, "Σ( ̄ロ ̄lll)"   Exit Sub  End If    Set mb = ThisWorkbook  myFd = mb.Path  Fnme = Dir(myFd & "\*.xls")    Do Until Fnme = ""   If Fnme <> mb.Name Then    On Error Resume Next    Set wb = Workbooks(Fnme)    If wb Is Nothing Then     Set wb = Workbooks.Open(myFd & "\" & Fnme)     flg = True    End If    On Error GoTo 0    i = i + 1    mb.Worksheets(1).Cells(i, 1).Value = wb.Worksheets(1).Range("S10").Value    If flg Then     wb.Close False '保存せずに閉じる     flg = False    End If   End If   Set wb = Nothing   Fnme = Dir()  Loop    Set mb = Nothing  MsgBox i & "個を取得しました", vbInformation End Sub

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 最小限の手直しでできる方法ですね、たすかりました。 ばっちりです!

関連するQ&A

  • エクセルVBAでBOOKに読み取りパスワード設定

    エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01()   Dim myfdr As String, fname As String   Dim mb As Workbook, wb As Workbook   Dim n As Long   With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定      If .Show = True Then       myfdr = .SelectedItems(1)     Else       MsgBox "キャンセルします。"       Exit Sub     End If   End With   Set mb = ThisWorkbook 'このコピー先ブックをmbとする。   fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索   n = 2   Do Until fname = Empty '全て検索     Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。     With mb.Sheets("Sheet1") '転記       .Cells(n, "B").Value = wb.FullName       .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value     End With     n = n + 1 'カウント     Application.DisplayAlerts = False     wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"     wb.Close     Application.DisplayAlerts = True     fname = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   MsgBox n - 2 & "件処理しましました。" End Sub

  • エクセルVBA 3/26夜の補足です

    おはようございます お忙しいに申し訳ありません 春から私用で使うための自作ソフトを作成したおります ご迷惑おかけします 指摘のサンプルです わたしなりに作成したものです Sub sheetcopy1() ThisWorkbook.Sheets("sheet1").Select Range("B2:K100").Select Selection.Copy Dim wb As Workbook Set wb = Workbooks.Add ThisWorkbook.Sheets("sheet1").Copy before:= _ wb.Worksheets(1) Set wb = Nothing End Sub これですと、新しいBOOKが起動しシートすべての項目が張り付きます シートの一部を(B2からK100)を移したいと思っています ワンクリックとはフォームのコマンドボタンで移動できればと思っています よろしければお知恵をおかりしたくおもいます よろしくお願いします

  • VBA Excel処理の追加を2点教えてください

    Office2003(SP3) 以下は、昔、教えてもらったExcel VBAスクリプトで、よく使わせて もらってます。「C:\mybooks\」にあるxlsファイル(a001.xls、a002.xls、 a003.xls・・・・)を片っ端から開き、 1つのBookに束ねる動作をします。 これだけでも大変便利なのですが、もう少し改善いたしたく。 (1) 束ねられたBookのSheet名が、Sheet1、Sheet1 (2)、Sheet1 (3)、 Sheet1 (4)・・・ になってしまいます。そこで、ファイル名から拡張子を落 とした文字列をSheet名にセットする記述をご教示下さい。 (2) a001.xls、a002.xls、a003.xls・・・は、それぞれSheet1、Sheet2、 Sheet3を含みます。Sheet1だけが抜き取られてSheet2、Sheet3が残された大量 の残骸Bookが開きっぱなしになります。これら、保存せずに閉じる記述を追加 したいのですが。 よろしくお願い致します。 Sub OpenFiles() Dim i As Integer Dim wb As Workbook Dim fname Dim dirname As String ' i = 1 dirname = "C:\mybooks\" fname = Dir(dirname + "*.htm") If fname <> "" Then Do While fname <> "" If fname <> "." And fname <> ".." Then If i = 1 Then ' 最初のファイルを開く Workbooks.OpenText FileName:=dirname + fname Set wb = ActiveWorkbook ' 最初のファイルを新規ブックに複製して閉じる。 ActiveSheet.Copy wb.Close Set wb = ActiveWorkbook Else ' 2番目以降のファイルは複製した最初のファイルに追加 Workbooks.OpenText FileName:=dirname + fname ActiveSheet.Move After:=wb.Worksheets(wb.Worksheets.Count) End If i = i + 1 End If fname = Dir Loop Else MsgBox "検索条件を満たすファイルはありません。" End If Set wb = Nothing End Sub

その他の回答 (4)

  • 回答No.5
  • keithin
  • ベストアンサー率66% (5278/7939)

ん? ごめんなさいね。つまんないとこで誤記って,ご迷惑をおかけましました。 間違い: mb.Sheets(1).Cells(i, 1) = Workbooks(fname).Sheets(1).Range("S10") 正解: mb.Sheets(1).Cells(i, 1) = Workbooks(fnme).Sheets(1).Range("S10")

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 気が付きませんでした。 やはり Option Explicit 必要ですねえ・・・・。

  • 回答No.3
  • mimeu
  • ベストアンサー率49% (39/79)

そんなに難しくしないでも、関数をひとつ作れば話が簡単になります。 たとえば、こんな感じです。 本文の中で   Dim b既に開いている As Boolean   Do Until fnme = Empty     If fnme <> mb.Name Then       If 既に開いている(fnme) Then         b既に開いている = true         Set wb = Workbooks(fnme)       Else         b既に開いている = false         Set wb = Workbooks.Open(myfd & "\" & fnme)       End If       i = i + 1    ~~~~ 中略 ~~~~       If Not b既に開いている Then (ファイルを閉じるロジック)    ~~~~ 以下省略 ~~~~ Function 既に開いている(ファイル名 As String) As Boolean   Dim ブック As Workbook   For Each ブック In Application.Workbooks     If ファイル名 = ブック.Name Then       既に開いている = True       Exit Function     End If   Next   既に開いている = False End Function

共感・感謝の気持ちを伝えよう!

質問者からのお礼

なるほど、いろいろやりかたがありますね。 勉強になります。 ありがとうございました。

  • 回答No.2
  • mt2008
  • ベストアンサー率52% (885/1701)

On Error Resume Nextを使った手抜きの方法を。 開くブック名が決まったら、On Error Resume Nextを設定して、そのブック名をWorkbooks.Nameで取得して変数に代入します。 既に開いてあるブックならブック名が取得できますし、開いていなければエラーで次に処理が進むため変数は空っぽになります。 で、閉じる時にその変数が空っぽ=開いていなかった 場合、保存せずに閉じます。 以下、Do Until fnme = Empty のループ部分のみ   Do Until fnme = Empty     If fnme <> mb.Name Then       chk = ""       On Error Resume Next         chk = Workbooks(fnme).Name       On Error GoTo 0       Set wb = Workbooks.Open(myfd & "\" & fnme)       i = i + 1       mb.Sheets(1).Cells(i, 1) = wb.Sheets(1).Range("S10")       If chk = "" Then wb.Close (False) '保存せずに閉じる     End If     fnme = Dir   Loop

共感・感謝の気持ちを伝えよう!

質問者からのお礼

なるほど! 目からうろこの方法です。 ありがとうございました。

  • 回答No.1
  • keithin
  • ベストアンサー率66% (5278/7939)

たとえばジミチーに,当該のブックが既に開いてるかどうかチェックしながら進めるようにするのも簡単な手の一つですね。  dim book_is_Open_flg as boolean '  :(中略)  Do Until fnme = Empty   If fnme <> mb.Name Then      i = i + 1    on error goto errhandle    mb.Sheets(1).Cells(i, 1) = workbooks(fname).Sheets(1).Range("S10")    on error goto 0    if book_is_Open_flg = true then     workbooks(fname).close false     book_is_Open_flg = false    end if   End If   fnme = Dir  Loop  Set mb = Nothing  Set wb = Nothing  MsgBox i  exit sub errhandle:  Workbooks.Open(myfd & "\" & fnme)  book_is_Open_flg = true  resume End Sub もう一個別にエクセルアプリケーションを配下に起動させて,そちらで当該のブックが開いていようがいまいがreadonlyで新たにブックを開いてしまい,値を取ってくるような手もありかもしれません。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。 下記のようにやってみましたが最初のBOOKを開いたところで無限ループになってしまいます。 Sub TEST02()   Dim mb As Workbook, wb As Workbook   Dim myfd As String, fnme As String, ans As Byte, i As Long   Dim book_is_Open_flg As Boolean     ans = MsgBox("集計用フォルダーには回収したアンケートファイルとこの集計用ファイルしかないですね?", vbYesNo + vbQuestion, "( ̄∇ ̄) ? ")   If ans = vbNo Then     MsgBox "それじゃだめです。", vbCritical, "Σ( ̄ロ ̄lll)"     Exit Sub   End If     Set mb = ThisWorkbook   myfd = mb.Path   fnme = Dir(myfd & "\*.xls")     Do Until fnme = Empty     If fnme <> mb.Name Then       i = i + 1       On Error GoTo errhandle       mb.Sheets(1).Cells(i, 1) = Workbooks(fname).Sheets(1).Range("S10")       On Error GoTo 0       If book_is_Open_flg = True Then         Workbooks(fname).Close False         book_is_Open_flg = False       End If     End If     fnme = Dir   Loop      Set mb = Nothing   Set wb = Nothing   MsgBox i   Exit Sub    errhandle:   Workbooks.Open (myfd & "\" & fnme)   book_is_Open_flg = True   Resume End Sub

関連するQ&A

  • Excel マクロで複数ブックのデータを一つのブックにまとめる方法

    マクロ初心者です。 1つのフォルダの中に複数のbook(sheetも複数)があります。 これを新しい1つのbookにまとめたいです。 sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。 どなたかの回答に下記マクロがありました。 Sub consolid() 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.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub 非常によかったのですが、これですと (1)全てのsheetがコピーされてしまいます。 (2)また、保存しますか?とbookごとに聞いてきます。 上記のマクロのどこを変更すれば、(1)(2)を解決できますでしょうか? (エクセルは2002です) 以上、よろしくお願いします。

  • VBAについて質問です。

    VBAについて質問です。 現在、ExcelにてWorkbookを自動で作成するモジュールを作成しています。 モジュールを記載しているWorkbookを [wbSorce] 自動で作成されるWorkbookを [wbNew] とします。 [wbSorce] でモジュールを実行すると、 [wbNew] を新規に作成し、 データを入力して保存するのですが、保存する際に [wbNew] のイベントハンドラ [Workbook_Open] に 保存された [wbNew] を開いた時の挙動を記載するには どうすればよいでしょうか? サンプルは下記になります。 ****[wbSorce]のモジュール**** Sub wbNew_Sakusei()   Dim wb As Workbook   Dim wb2 As Workbook   Dim i As Integer   Set wb = ThisWorkbook   Set wb2 = Workbooks.Add   For i = 1 To 5     wb2.Sheets(1).Cells(1, i) = wb.Sheets(1).Cells(1, i)   Next   wb2.SaveAs Filename:="wbNew" End Sub ****[wbNew]に記述したいモジュール**** Private Sub Workbook_Open()   ActiveWindow.ScrollRow = 1   MsgBox "Workbook_Openイベントが発生しました。" End Sub

  • Textboxに入力してBookを開く

    VBAを勉強して仕事に活かしたいと思っています。 ユーザーフォームを有効に使いたいと・・ TextboxにBook名を入力してBook(同一フォルダー内にある)を開けるようにしたいと思い次のコードを書きましたが全てのBookが開いてしまいました。 Dim MyP As String Dim MyF As String Dim NewBK As Workbook Dim flg As Boolean MyP = ThisWorkbook.Path & Application.PathSeparator MyF = Dir(MyP & "*.xls") Application.ScreenUpdating = False Do While MyF <> "" If MyF <> ThisWorkbook.Name Then On Error Resume Next Set NewBK = Workbooks(MyF) On Error GoTo 0 If NewBK Is Nothing Then flg = True Set NewBK = Workbooks.Open(MyP & MyF) End If 検索_1 NewBK If flg Then NewBK.Close False flg = False End If Set NewBK = Nothing End If MyF = Dir() Loop Application.ScreenUpdating = True ThisWorkbook.Activate End Sub '*** Form呼び出し時の処理 *** Private Sub 検索_1() Dim findText As String '探す文字列(Text1に入力) Dim rg As Object '探し出したブック findText = Text1.Text Set rg = Workbooks.Find(What:=findText, LookAt:=xlWhole) If Not rg Is Nothing Then Workbooks.Open End If End Sub このコードは本やネットの過去ログをみて参考にして書いたものです。 どなたかわかる方 アドバイスお願いします。

  • エクセルVBAで読み取りパスワード回避

    エクセル2010です。 以下のコードで任意のフォルダ内のエクセルBOOKから所定のデータを取得できます。 しかし、指定フォルダ内に読み取りパスワードが設定されたものがあると、開くことができずに止まってしまいます。 読み取りパスワードが同一で、事前に分かっていればコードにPassword:="AAAABBBB" などと書き入れればいいと思うのですが、事前にはわかりませんし、パスワードもそれぞれ異なります。 そこで、開けなかった場合には、そのBOOKを飛ばしてすすみ、別シートに飛ばしたBOOK名を記録しておきたいのです。 (BOOK作成者にあとからパスワードを聞くため) しかし、残念ながらどのように書けばいいのか思いつきません。 ご指導いただければ幸いです。 Sub TEST001()   Dim wb(1) As Workbook   Dim ws(1) As Worksheet   Dim myFdr As String, fn As String   Dim i As Long   With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定     If .Show = True Then        myFdr = .SelectedItems(1)     Else       Exit Sub     End If   End With   Application.ScreenUpdating = False '画面更新を一時停止   Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。   Set ws(0) = wb(0).Sheets(1) 'wb(0)の1枚目のシートをws(0)とする。   fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索   Do Until fn = Empty '全て検索     Application.EnableEvents = False     Set wb(1) = Workbooks.Open(myFdr & "\" & fn, UpdateLinks:=False, ReadOnly:=True) 'そのブックを開きwb(1)とする。     Set ws(1) = wb(1).Worksheets(1)     i = i + 1     ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記     ws(0).Cells(i, "B").Value = wb(1).Name     ws(0).Cells(i, "C").Value = ws(1).Name     wb(1).Close (False) '保存せず閉じる     Application.EnableEvents = True     fn = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   Application.ScreenUpdating = True '画面更新停止を解除   MsgBox i & "個取得" End Sub

  • Excel マクロで複数ブックのデータを一つのブックにまとめる方法

    マクロ初心者です。 1つのフォルダの中に複数のbook(sheetも複数)があります。 これを新しい1つのbookにまとめたいです。 回答に下記マクロがありました。 Sub consolid() 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.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub これで使用した所マクロを実行する度に何度も同じシートが コピーされてしまいます。 できれば同じ名前のシートは上書きにしてマクロを何度も使用できるように【各BOOKは毎週更新されて私のフォルダに入ってきます】したいのですが そのような事は可能なのでしょうか? どなたか分かる方教えてください。お願い致します。

  • エクセルVBAで作成した別ブックにVBAを記述したい

    VBAで別ファイルの作成は下記で出来ているのですが、出来上がったファイルにVBAを記述する方法がわかりません。 具体的には一番下のSub TEST()を新しいブックの標準モジュールに記述したいのと、sheet1に Private Sub Worksheet_Change(ByVal Target As Range) MsgBox "ChangeTEST" End Sub を入れたいです。 また Private Sub Workbook_Open() MsgBox "OpenTEST" End Sub も入れたいのです。 どうぞご教示ください。 Sub 複製() Dim wb As Workbook, sc As Integer sc = Application.SheetsInNewWorkbook Application.SheetsInNewWorkbook = 1 Set wb = Workbooks.Add Application.SheetsInNewWorkbook = sc wb.Sheets("Sheet1").Select ThisWorkbook.Sheets("Sheet1").Cells.Copy wb.Sheets("Sheet1").Select Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Buttons.Add(123, 195, 68.25, 15).Select Selection.OnAction = "TEST" Selection.Characters.Text = "TEST" ActiveWorkbook.Close ThisWorkbook.Activate Sheets("Sheet1").Select End Sub Sub TEST() MsgBox "TEST!!" End Sub よろしくお願いします。

  • VBAのエラーで、セルの書式が多すぎるため書式を追加できません。

    Excel2003のVBAで質問です。 複数ブック→1つのブックで複数シート にするマクロを作成しています。 今まではうまく実行できていたのですが、 wb.Sheets("12月").Range("A1:AO45").Copy mb.Sheets(mb.Sheets.Count).Range("A1").Select mb.Sheets(mb.Sheets.Count).Paste を追加したところ、途中までは大丈夫なのですが、ある一定数以上のブックで 「セルの書式が多すぎるため書式を追加できません」とメッセージが出ます。 VBAのどの辺りを修正すればよいのでしょうか? また、都度 「コピーまたは移動先セルの内容を置き換えますか?」や「クリップボードにおおきな情報があります。この情報を貼り付けられるようにしますか?」などに「Y」や「N」を都度入力しなくてもよいようにできますでしょうか? 以上、よろしくお願いします。 下記は全マクロ。 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.Sheets("12月").Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く wb.Sheets("12月").Range("A1:AO45").Copy mb.Sheets(mb.Sheets.Count).Range("A1").Select 'コピー先シートを選択してアクティブにする mb.Sheets(mb.Sheets.Count).Paste 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 n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 Dim ws As Worksheet '全てのシートの色をなしにする For Each ws In Worksheets ws.Tab.ColorIndex = xlColorIndexNone Next MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _ + Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _ + Chr(&HD) + Chr(&HA) + "" _ + Chr(&HD) + Chr(&HA) + "", , "( ̄ー ̄)v " End Sub

  • マクロで複数ブックのデータを一つのブックにコピー

    マクロ超初心者です。 1つのフォルダの中に複数のbook(sheetも複数)があります。 これを新しい1つのbookにまとめたいです。 sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。 どなたかの回答に下記マクロがありました。 Sub consolid() 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.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub このマクロを使わせていただき、 これでいける!と思ったのですが、255文字以上のコピーが出来ません。 どのようにすればよいでしょうか?

  • エクセルVBA フォルダ内のどんなシート名であっても読み込みたい

    フォルダ内の別ブック(D3で指定)の「情報」シートを読み込んで対象年月日に該当するデータを抽出して別ブックに貼り付けるものなんですが、下のコードではSet ws = wb.Worksheets("情報")と、なっていて、限定しているのですが、これをD3のファイルのどんなシート名であっても読み込みたいのですが、どのようにコードにしたらいいでしょうか?D3で指定するブックには必ずひとつのシートしかありません。 よろしくお願いします。 Sub test_1() Dim wb As Workbook Dim ws As Worksheet Dim ms As Worksheet Dim nb As Workbook Dim r As Long Set ms = ThisWorkbook.Worksheets("メニュー") Set wb = Workbooks.Open(ms.Parent.Path & "\" & ms.Range("D3").Value) Set ws = wb.Worksheets("情報") Set nb = Workbooks.Add With ws .Range("Q1").AutoFilter _ Field:=17, _ Criteria1:=">=" & ms.Range("D5").Text, _ Operator:=xlAnd, _ Criteria2:="<=" & ms.Range("F5").Text With .AutoFilter.Range r = .Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count If r = 1 Then MsgBox "抽出対象データ無し。" wb.Close False nb.Close False Set wb = Nothing: Set ws = Nothing Set ms = Nothing: Set nb = Nothing Exit Sub End If .Copy End With End With With nb.Worksheets(1) .Paste With .Range("A1:AG1") .Interior.ColorIndex = 6 .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With End sub

  • VBAでシート名を変える、グラフのリンクを切る等を教えてください

    以前、「複数ブックのシートを一つのブックにコピーする」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 以上、ご教示願います。。。