こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

投稿日時 - 2009-07-24 23:55:49

QNo.5153108

暇なときに回答ください

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

こんな感じでいいのでは
Sub GetSheets()
  Dim sName As String, sDir As String, n As Integer
  Dim wb As Workbook, w As Workbook
  Dim ws As Worksheet
  Dim bflag As Boolean

  sDir = "c:\mybooks\"
  sName = Dir(sDir & "a*.htm")
  ' 画面の更新の抑止
  Application.ScreenUpdating = False
  While sName <> ""
    ' 取得ファイル名のブックを開く
    Application.OpenText FileName:= sDir & sName
    Set w = ActiveWorkbook
    Set ws = w.Sheets("Sheet1")
    ' Sheet1の名前を変更
    ws.Name = Replace(sName, ".xls", "")
    If wb Is Nothing Then
      ' まとめるためのブックを追加
      Set wb = Workbooks.Add
      bflag = True
    End If
    ' 対象シートをコピー
    ws.Copy after:=wb.Worksheets(wb.Worksheets.Count)
    ' アラートの抑止
    Application.DisplayAlerts = False
    If bflag Then
      ' 新規ブックの Sheet1,Sheet2,Sheet3を削除
      For n = wb.Worksheets.Count To 1 Step -1
        If Left$(wb.Worksheets(n).Name, 5) = "Sheet" Then
          wb.Worksheets(n).Delete
        End If
      Next
    End If
    ' 開いたブックを閉じる
    w.Close
    ' アラートの抑止の解除
    Application.DisplayAlerts = True
    Set ws = Nothing
    Set w = Nothing
    sName = Dir
  Wend
  ' 画面更新の抑止を解除
  Application.ScreenUpdating = True

End Sub

# 字下げには全角スペースを使用しています

投稿日時 - 2009-07-25 15:39:33

お礼

redfox63さん、御礼が大変遅くなったことをまずはお詫び申し上げます。

別の作業に追われており、ようやく本件に取り掛かることができました。
さて詳細なコードまでご提示いただき、大変ありがとうございました。

実行してみると、

' 取得ファイル名のブックを開く
Application.OpenText FileName:= sDir & sName

ここで以下のエラーで止まってしまうようです。

「実行時エラー '438':
オブジェクトは、このプロパティまたはメソッドをサポートしていません。」

「Application.OpenText FileName」をGoogleで調べてみましたが、
本質問にしかHITしないようで、、、

当方、Excel2003ですが、「Application.OpenText」はExcel2007など新しい
バージョンでの記述なのでしょうか?

まことに厚かましいですが、もし原因が簡単にわかるようでしたら
ご教示いただけますと幸いです。

投稿日時 - 2009-08-09 23:43:02

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.3

Application.OpenText は間違えですね
Workbooks.OpenTextです

投稿する際にコメントなどを追加したときに何かを間違えたのだと思います
大変失礼しました m(__)m

投稿日時 - 2009-08-10 03:42:38

お礼

redfox63さん、フォローありがとうございました。
ばっちり動きました、大変作業がはかどります、ありがとうございます。

投稿日時 - 2009-08-11 13:01:51

ANo.1

まずは希望動作のマクロ記録をとりましょう。
シート名の変更に関するコード
ファイルを閉じるコードがすぐにわかるので現コードでループしているうちのどこに入れたらいいか考えましょう。

手作業でする順番を考えればすぐにわかりますよ

投稿日時 - 2009-07-25 01:18:14

お礼

御礼遅くなってすみません。

アドバイスありがとうございました。
記録をとってみたのですが
ファイルを閉じると記録したものも全て吹っ飛んでしまい、
そこで挫折しかけていました、、、

地道に研究してみます。ありがとうございます。

投稿日時 - 2009-08-09 23:35:22

あなたにオススメの質問