本

社内業務関連
http://www.amazon.co.jp/%E5%BA%83%E5%A0%B1%E9%83%A8-%E5%9B%B3%E8%A7%A3%E3%81%A7%E3%82%8F%E3%81%8B%E3%82%8B%E9%83%A8%E9%96%80%E3%81%AE%E4%BB%95%E4%BA%8B-%E4%BD%90%E6%A1%91-%E5%BE%B9/dp/4820716301/ref=sr_1_1?ie=UTF8&s=books&qid=1205470130&sr=1-1

全ファイル結合（とあるファイル専用）

Sub Button1_Click()
Const cnsYEN = "\"
Dim xlAPP As Application ' Excel.Application
Dim objFS As FileSearch ' FileSearch
Dim objFSO As FileSystemObject ' FSO
Dim objWBK As Workbook ' 処理ブック
Dim objSH As Worksheet ' 処理シート
Dim vntF As Variant ' 発見したファイル名の配列
Dim strPATHNAME As String ' 指定フォルダ名
Dim strFILENAME As String ' 検出したファイル名
Dim tblSH As Variant ' 表示シートの配列を格納
Dim IX As Long ' WORK
Dim swESC As Boolean ' Escキー判定
Dim activeFN As String ' このブック名
Dim rowCnt As Integer ' 行カウンタ

' 「フォルダの参照」よりフォルダ名の取得(modAPIBrowseForFolder2に収容)
strPATHNAME = BrowseForFolder("フォルダを指定して下さい", True)
If strPATHNAME = "" Then Exit Sub

Set xlAPP = Application
With xlAPP
.ScreenUpdating = False ' 画面描画停止
.EnableEvents = False ' イベント動作停止
.EnableCancelKey = xlErrorHandler ' Escキーでエラートラップする
End With ' このブック名の退避

activeFN = ActiveWorkbook.Name
Sheets("マージ集計").Activate
DeleteContents.Delete_All

' 指定フォルダ内のExcelブックを順次処理
Set objFS = xlAPP.FileSearch
Set objFSO = New FileSystemObject
With objFS
.LookIn = strPATHNAME ' Search開始フォルダ
.Filename = "*.xls" ' 探索ファイル式
.SearchSubFolders = True ' サブフォルダも探索
' 処理開始
If .Execute() = 0 Then
MsgBox "このフォルダにはExcelワークブックは存在しません。"
GoTo Button1_Click_EXIT
End If

' 見つかったファイル分のループ
For Each vntF In .FoundFiles ' Escキー打鍵判定
DoEvents
If swESC = True Then
' 中断するのかをメッセージで確認
If MsgBox("中断キーが押されました。ここで終了しますか？", _
vbInformation + vbYesNo) = vbYes Then
GoTo Button1_Click_EXIT
Else
swESC = False
End If
End If

xlAPP.StatusBar = vntF
' FSOにてファイルを取得
With objFSO.GetFile(vntF)
' ワークブックを開く(読み取り専用)
Set objWBK = Workbooks.Open( _
Filename:=.Path, UpdateLinks:=False, ReadOnly:=True)
'---------------------------------------------------------------
' ↓↓↓ 検索した１ファイル単位の処理 ↓↓↓
' シートのコピー(機能構成表)
objWBK.Sheets("機能構成表01").Copy After:= _
Workbooks(activeFN).Sheets(Workbooks(activeFN).Sheets.Count)
' 開いたブックをClose
objWBK.Close SaveChanges:=False

' カテゴリの列があったりなかったりするので調整（列追加）
Workbooks(activeFN).Sheets("XXXXXXX").Activate

Do While Cells(1, 5) = "" And Cells(2, 5) = ""
Columns("C:C").Select
Selection.Insert
Shift:=xlToRight
Cells(1, 3) = "ダミーカテゴリ" ' 列名

Loop Cells(1, 1).CurrentRegion.Copy

Sheets("マージ集計").Activate
rowCnt = Range("E65536").End(xlUp).Row
Cells(rowCnt + 2, 6) = .Name
Cells(rowCnt + 1, 1).Select
Selection.PasteSpecial

If rowCnt > 1 Then
Rows(rowCnt + 1).Delete Shift:=xlUp
End If

Sheets("XXXXXXX").Activate
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
' ↑↑↑ 検索した１ファイル単位の処理 ↑↑↑
'---------------------------------------------------------------
End With
Next vntF
End With
GoTo Button1_Click_EXIT

'----------------
' Escキー脱出用行ラベル
Button1_Click_ESC:
If Err.Number = 18 Then
' EscキーでのエラーRaise
swESC = True
Resume
ElseIf Err.Number = 1004 Then
' 隠しシートや印刷対象なしの実行時エラーは無視
Resume Next Else
' その他のエラーはメッセージ表示後終了
MsgBox Err.Description
End If

'----------------
' 処理終了
Button1_Click_EXIT:
EditHeader.Edit
With xlAPP
.StatusBar = False ' ステータスバーを復帰
.EnableEvents = True ' イベント動作再開
.EnableCancelKey = xlInterrupt ' Escキー動作を戻す
.Cursor = xlDefault ' カーソルをデフォルトにする
.ScreenUpdating = True ' 画面描画再開
End With
Set objWBK = Nothing
Set objFSO = Nothing
Set objFS = Nothing
Set xlAPP = Nothing
End Sub

BrowseForFolderモジュール

フォルダ参照のモジュール
http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_110.html#BrowseForFolder2

ここの

modAPIBrowseForFolder2.bas

に

Public Function BrowseForFolder

がある。

セルの結合を解除する（シート全体）

Sub CancelJoin()

Cells.Select

With Selection

.VerticalAlignment = xlTop

.Orientation = 0

.AddIndent = False

.ReadingOrder = xlContext

.MergeCells = False

End With

End Sub

重複行の削除

Sub deleteLow()
Dim lastrow As Integer
Dim i As Long
Dim cnt As Long

lastrow = Range("A65536").End(xlUp).Row
cnt = 1

For i = lastrow To 2 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value And _
Cells(i, 2).Value = Cells(i - 1, 2).Value And _
Cells(i, 3).Value = Cells(i - 1, 3).Value And _
Cells(i, 4).Value = Cells(i - 1, 4).Value And _
Cells(i, 5).Value = Cells(i - 1, 5).Value _
Then
Cells(i, 1).EntireRow.Delete Shift:=xlUp
cnt = cnt + 1

Else

Cells(i, 6) = cnt
cnt = 1

End If

Next i

End Sub

シートのコピー

Sub SheetCopy()
Dim xlApp As Application ' Applicationオブジェクト
Dim activeFN As String ' このブック名
Dim refferFN As String ' 参照元ブック名

' このブック名の退避
activeFN = ActiveWorkbook.Name

' Applicationオブジェクトの取得
Set xlApp = Application

' ファイルを開く
xlApp.StatusBar = "読み込むファイルを指定して下さい。"
strFILENAME = xlApp.GetOpenFilename("Microsoft Excel ブック,*.xls")
Workbooks.Open strFILENAME
refferFN = ActiveWorkbook.Name

' シートのコピー(From)
Workbooks(refferFN).Sheets("From").Copy After:= _
Workbooks(activeFN).Sheets(Workbooks(activeFN).Sheets.Count)
' シートのコピー(To)
Workbooks(refferFN).Sheets("To").Copy After:= _
Workbooks(activeFN).Sheets(Workbooks(activeFN).Sheets.Count)

' ブックを閉じる
Workbooks(refferFN).Close
' メインシートアクティブ
Workbooks(activeFN).Sheets(1).Activate

End Sub

最終行の取得

Function maxLine(tgtCol As Integer) As Long
' 収容最終行の判定(Excel認知の最終行から上に向かってデータがある行を探す)
maxLine = Cells.SpecialCells(xlCellTypeLastCell).Row
Do While Cells(maxLine, tgtCol).Value = ""
maxLine = maxLine - 1
Loop
End Function