2006年8月30日
【エクセル】複数のブックを一つにまとめる ２
ひとつのシートじゃなくて、別々のシートにまとめたい？
むしろそういう場合の方が多いかもしれません。複数のブックを別シートにまとめるマクロ作っちゃいました。
Sub 複数のブックをまとめる()
Dim myWorkbook As Workbook, i As Long
Dim theName, theDir As String
Application.ScreenUpdating = False
'現在のカレントパスのtenkiフォルダに移動する
theDir = ThisWorkbook.Path & "\tenki"
'拡張子xlsのファイル名を取り出す
theName = Dir(theDir & "\*.xls")
Do While theName <> ""
Set myWorkbook = Workbooks.Open(theDir & "\" & theName)
myWorkbook.Worksheets(1).Copy After:= _
ThisWorkbook.Worksheets(Worksheets.Count)
ActiveSheet.Name = theName
myWorkbook.Close
theName = Dir()
Loop
Application.ScreenUpdating = True
Set myWorkbook = Nothing
Call 拡張子をとる
End Sub
Sub 拡張子をとる()
Dim i As Long
Dim cnt As Long
cnt = Worksheets.Count
For i = 2 To cnt
Worksheets(i).Name = Left(Worksheets(i).Name, InStr(Worksheets(i).Name, ".") - 1)
Next i
End Sub
------------
2008.9.11
どうもこれでは15-30ブックくらいまでしかまとめられない。リソース不足とエラーが出る。今のところ新規のブックで複数回にわけるくらいしか解決策は思いつかない。抜本的にコードを見直す必要がありそうだ。コピーするところがエラーになるので、その辺かと思う。クリップボードのコピーを解放するコードをネットで見つけたが、効果は不明である。
------------
2008.9.12
まとめられるブック、シートの数は、マシンの性能とワークシートのデータ量に依存している。色とかそのような細かいセルの書式設定も当然サイズに関係している。使用しているセルの領域が大きければ大きいほど、リソースを占有しています。まとめ先のブックに既定で15ワークシートある状態から実行しても、最初の一枚でリソース不足となってしまう。これを解決するのはなかなか難しい。
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As LongSub ClipClear()
Dim lngRtn As LonglngRtn = OpenClipboard(0)
lngRtn = EmptyClipboard
lngRtn = CloseClipboard
End Sub出典：Programing of なりさん(Java,VBA,Sybase)
http://programing.narisan.com/?eid=188455
統合したバージョン
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As LongSub 複数のブックをまとめる()
Dim myWorkbook As Workbook, i As Long
Dim theName, theDir As StringApplication.ScreenUpdating = False
'現在のカレントパスのtenkiフォルダに移動する
theDir = ThisWorkbook.Path & "\tenki2"
'拡張子xlsのファイル名を取り出す
theName = Dir(theDir & "\*.xls")Do While theName <> ""
Set myWorkbook = Workbooks.Open(theDir & "\" & theName)
myWorkbook.Worksheets(1).Copy After:= _
ThisWorkbook.Worksheets(Worksheets.Count)
Call ClipClear
ActiveSheet.Name = theName
myWorkbook.Close
theName = Dir()Loop
Application.ScreenUpdating = True
Set myWorkbook = NothingCall 拡張子をとる
End Sub
Sub 拡張子をとる()
Dim i As Long
Dim cnt As Longcnt = Worksheets.Count
For i = 2 To cnt
Worksheets(i).Name = Left(Worksheets(i).Name, InStr(Worksheets(i).Name, ".") - 1)
Next i
End Sub
Sub ClipClear()
Dim lngRtn As LonglngRtn = OpenClipboard(0)
lngRtn = EmptyClipboard
lngRtn = CloseClipboard
End Sub
- by editor
- at 14:54
編集長のおすすめの一冊！2010
comments