本

社内業務関連
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

データクリア

Const cnInitPos = "A3"

Sub Clear_All()
Range(cnInitPos).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
End Sub

マッチング

Dim chapter As String
Dim section As String
Dim subSection As String
Dim data As String
Dim lnIdxFrom As Integer
Dim lnIdxTo As Integer
Dim colIdx As Integer

Sub MatchData()
lnIdxFrom = 2
' シートTo
Sheets("To").Activate
maxlnTo = maxLine.maxLine(4)
' シートFrom
Sheets("From").Activate
maxlnFrom = maxLine.maxLine(4)

Do While lnIdxFrom <= maxlnFrom

chapter = Cells(lnIdxFrom, 1)
section = Cells(lnIdxFrom, 2)
subSection = Cells(lnIdxFrom, 3)

colIdx = 4

Do While Cells(lnIdxFrom, colIdx) <> ""

data = Cells(lnIdxFrom, colIdx)

' 対象シート検索
Sheets("To").Activate
lnIdxTo = 2

Do While lnIdxTo <= maxlnTo

If Cells(lnIdxTo, 4).Value = data Then
Cells(lnIdxTo, 5) = chapter
Cells(lnIdxTo, 6) = section
Cells(lnIdxTo, 7) = subSection
Exit Do
End If
lnIdxTo = lnIdxTo + 1
Loop

Sheets("From").Activate
colIdx = colIdx + 1
Loop

lnIdxFrom = lnIdxFrom + 1
Loop

End Sub