スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

VBAハジメマシタ

C言語系しかやってませんが、実はプログラマ的なことをしている菩薩デス。

最近、暇だったのでVBAハジメマシタ。

どうせ、Web上に落ちているものをを4コ1にしたようなものなので、
世間様にお返ししちゃおっかなぁーなーんて。

つたないものですので、文句はナシで。
説明は特にしない、ググれ。


■複数のExcelをまとめてくれるマクロ
 コードは続きを読むで (゚Д゚)b

 久々にコード書いたけど、やっぱりバグって出るものなのね orz
■細切れになったExcelをまとめてくれるマクロ。
 Book上に
 ・まとめたいファイルパス
 ・書き出し先
 ・ファイル名
 を記入するセルを用意して、ボタンぽちっと押すとまとめてくれる。
 サイズによるけど、15ファイルくらいで"その2、その3..."と追加して行ってくれるのよ!

■コード
※最初と最後に"Sub ワショーイ""End Sub"をつけてね。

******ここから******

'==== 変数定義 ====
Dim nb As Workbook, wb As Workbook
Dim fname As String, n As Integer, out_num As Integer
Dim ndir As String, wdir As String, nfile As String

Dim s As Variant, flag As Boolean, m As Integer
Dim isrnw As Boolean, fcount As String


Application.ScreenUpdating = False '画面更新を一時停止

'==== 必要なPath、File名をExcel内から取得
ndir = Range("B11").Formula
wdir = Range("B12").Formula
nfile = Range("B13").Formula


'==== 新規にブックを作成
Set nb = Workbooks.Add
mname = wdir & "\" & nfile & ".xls"
ActiveWorkbook.SaveAs (mname) '上書き保存
Application.DisplayAlerts = False 'メッセージを出さない

fname = Dir(ndir & "\*.xls") 'フォルダ内のExcelブックを検索


'==============================================
' 指定されたPathからExcelを根こそぎ読み出し、
' 新規BookにSheetとして追加していく
'==============================================
m = 2 'シートの送り番用
out_num = 1 '作成したファイル数用

flag = True
Do Until fname = Empty '全て検索
If fname <> nb.Name Then 'ブック名がこのブックの名前でなければ
Set wb = Workbooks.Open(ndir & "\" & fname) 'そのブックを開きwbとする。
wb.ActiveSheet.Copy After:=nb.Sheets(nb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く

orgsheet = ActiveWorkbook.ActiveSheet.Name 'シートタブに表示される名前
nsheet = Range("BE46").Formula 'セルBE46をシート名にするために取得
If nsheet = Empty Then '取れたかどうかの確認
nsheet = orgsheet
End If

'---- 同じシート名がないかを確認
For Each s In Sheets
If s.Name = nsheet Then '同じシート名があった
If ActiveWorkbook.ActiveSheet.Name <> nsheet Then 'ActiveSheet名と同じ場合は無視
flag = True
End If
Exit For
End If
Next s
If flag = True Then '同じシートがあったので送り番をつける
Worksheets(orgsheet).Name = nsheet & "_" & m '新しいをシート名を入れる
m = m + 1
flag = False
Else 'そのままシート名を突っ込む
Worksheets(orgsheet).Name = nsheet
m = 2 '送り番初期化
flag = False
End If

wb.Close (False) '有無を言わずに保存せず閉じる
n = n + 1 'ブック数をカウント

'==== 新規ファイルのシートが15を超えたら新しくファイルを作成する ====
Select Case n
Case 15
fcount = "_02.xls"
isrnw = True
Case 30
fcount = "_03.xls"
isrnw = True
Case 45
fcount = "_04.xls"
isrnw = True
Case 60
fcount = "_05.xls"
isrnw = True
Case 75
fcount = "_06.xls"
isrnw = True
Case 90
fcount = "_07.xls"
isrnw = True
Case 105
fcount = "_08.xls"
isrnw = True
Case 120
fcount = "_09.xls"
isrnw = True
Case n > 135 '大杉の場合はフォルダ分けを促す
MsgBox n & "件以上のまとめはムリ or2 " & vbCr & _
"1フォルダ120以下くらいに分けて作成してね"
Exit Sub 'マクロ抜ける
End Select

'==== 15ファイルまとまったかどうかを見る
If isrnw = True Then
'==== いらないシートを消す ====
nb.Worksheets("Sheet1").Delete
nb.Worksheets("Sheet2").Delete
If nb.Worksheets.Count > 1 Then
nb.Worksheets("Sheet3").Delete
End If
'==== 今開いているのを閉じて、
ActiveWorkbook.Save '上書き保存
Application.DisplayAlerts = False 'メッセージを出さない
ActiveWorkbook.Close '閉じる

'==== 新しくファイルを作成 ====
Set nb = Workbooks.Add
ActiveWorkbook.SaveAs (wdir & "\" & nfile & fcount) '上書き保存
Application.DisplayAlerts = False 'メッセージを出さない
out_num = out_num + 1
isrnw = False
End If

End If
fname = Dir 'フォルダ内の次のExcelブックを検索
Loop '繰り返す

'==== いらないシートを消す ====
nb.Worksheets("Sheet1").Delete
nb.Worksheets("Sheet2").Delete
If nb.Worksheets.Count > 1 Then
nb.Worksheets("Sheet3").Delete
End If

'==== 作成が終わったのでファイルを閉じる
ActiveWorkbook.Save '上書き保存
Application.DisplayAlerts = False 'メッセージを出さない
ActiveWorkbook.Close '閉じる

'==== 使用者へ、出来上がったファイルの告知
Application.ScreenUpdating = True '画面更新一時停止を解除

MsgBox n & "件のファイルまとめたっぽい (*´・ω・)(・ω・`*)ネー " & vbCr & _
vbCr & _
mname & vbCr & _
mname1 & vbCr & _
mname2 & vbCr & _
"全部で" & out_num & "ファイルが作成されました"

*****ここまで*****
スポンサーサイト

コメントの投稿

非公開コメント

プロフィール

突き抜け菩薩

Author:突き抜け菩薩
TW トレネ クラブ ナルシスツのクラブサイト代わりデス。

ステフリマスター(藁)のレシピ他、全く関係ない話やクラブ告知はこちらで!


おもに動くのこの子

00_キリン

愛してます、電柱
00_電柱

最近の記事
最近のコメント
最近のトラックバック
月別アーカイブ
カテゴリー
FC2カウンター
ブロとも申請フォーム

この人とブロともになる

ブログ内検索
RSSフィード
リンク
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。