[[20150414014714]]　『複数ブックの複数シートから一覧を作成する』（たけさん）　ページの最後に飛ぶ

『複数ブックの複数シートから一覧を作成する』（たけさん）

こんばんは
今夜もコードをながめながら、こんな時間になってしまいました

前任の方が残したVBAがあり、少しずつ勉強しているのですが、お力を貸してください

C;\集計の中に複数のXLSブックがあります
ブック内の複数のｾﾙの値を1枚の別ブックにコピペし、一覧にしています。

ブック名の数は日により異なり、名前も都度異なります
BOOK1　　1
BOOK2　　ｼｰﾄ1　ｼｰﾄ2
BOOK3　　ｼｰﾄあｼｰﾄい　ｼｰﾄう

それぞれのブックには1～20のシートがあります
シート名前も数もバラバラです

現在　ﾌﾞｯｸ内のｼｰﾄがそれぞれ1枚の場合は
前任の方が残してくれたVBAで処理できるのですが、
ｼｰﾄが複数になってしまい、処理ができない状態です

上記のように複数のｼｰﾄでの処理ができるようにするには
どの部分を手直しすればいいのでしょうか??

Option Explicit

Private Const OUTPUT_SHEET_NAME = "一覧"
Public Sub 一覧化(folder As String)

    Dim i As Long, j As Long
    Dim fileNo As Long
    Dim wkFN() As String    '処理対象ファイル名
    Dim wkFNF() As String   '処理対象ファイル名(full path)
    Dim sheetNames As New Collection
    Dim addresses As New Collection
    Dim itemNames As New Collection
    Dim extension As String

    '************検索結果、シートをクリア
    Call SheetClr(OUTPUT_SHEET_NAME, 1, 1, 1, 1)
    ThisWorkbook.Sheets(1).Activate

    If folder = "" Or Dir(folder, vbDirectory) = "" Then
        MsgBox folder & vbCrLf & "ディレクトリが見つかりません。終了します。"
        End
    End If

    '**********　ファイルを検索
    If FNSearch(folder, wkFNF, wkFN, "", True) = False Then 'ファイルが見つからない場合
        MsgBox "ファイルはありません。終了します。"
        End
    End If

    With ThisWorkbook.Worksheets(1)
        j = .UsedRange.Row + .UsedRange.Rows.Count - 1
        For i = 9 To j
            If .Cells(i, 3).Value <> "" _
             And .Cells(i, 4).Value <> "" _
             And .Cells(i, 5).Value <> "" Then
                sheetNames.Add .Cells(i, 3).Value
                addresses.Add .Cells(i, 4).Value
                itemNames.Add .Cells(i, 5).Value
            End If
        Next i
    End With

    Application.ScreenUpdating = False  '処理の動きを見えないようにする
    Application.DisplayAlerts = False   '保存確認ボックスを表示しないようにする
    'ヘッダー編集
    With ThisWorkbook.Sheets(OUTPUT_SHEET_NAME)
        .Cells(1, 1).Value = "No"
        .Cells(1, 2).Value = "ファイルパス"
        For i = 1 To itemNames.Count
            .Cells(1, i + 2).Value = itemNames.Item(i)
        Next i
    End With

    fileNo = 0
    For i = 1 To UBound(wkFN)
        Application.ScreenUpdating = True  '処理の動きを見えるようにする
        Application.StatusBar = wkFNF(i) & "を処理中"
        DoEvents
        Application.ScreenUpdating = False  '処理の動きを見えないようにする

        '***********エクセルの場合
        If InStr(wkFN(i), ".") Then
            extension = Mid(wkFN(i), InStrRev(wkFN(i), "."))
            If extension = ".xls" _
             Or extension = ".xlsb" _
             Or extension = ".xlsx" Then
                fileNo = fileNo + 1
                Call readExcel(fileNo, wkFNF(i), sheetNames, addresses)
            End If
        End If
    Next i

    With ThisWorkbook.Sheets(OUTPUT_SHEET_NAME)
        .Select
        .Range(Cells(2, 2), Cells(.UsedRange.Rows.Count, 2)).Select
        Call リンクはるぞっ
        .Cells(1, 1).Select
    End With

    Application.ScreenUpdating = True  '処理の動きを見えるようにする
    Application.StatusBar = ""

End Sub

Private Sub readExcel(fileNo As Long _

    , filePath As String _
    , sheetNames As Collection _
    , addresses As Collection)

    Dim i As Long
    Dim wkBook As Excel.Workbook

    Set wkBook = Application.Workbooks.Open(filePath)

    With ThisWorkbook.Worksheets(OUTPUT_SHEET_NAME)
        .Cells(fileNo + 1, 1).Value = fileNo
        .Cells(fileNo + 1, 2).Value = filePath
        For i = 1 To sheetNames.Count
            .Cells(fileNo + 1, i + 2).Value = wkBook.Worksheets(sheetNames.Item(i)).Range(addresses.Item(i)).Value
         Next i
    End With

    wkBook.Close
    Set wkBook = Nothing
End Sub

Sub リンクはるぞっ()

    Dim myRange As Range
    Dim i As Long
    Dim j As Long

    Set myRange = Selection

    For i = myRange.Column To myRange.Column + myRange.Columns.Count - 1
        For j = myRange.Row To myRange.Row + myRange.Rows.Count - 1
            Cells(j, i).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, address:=Cells(j, i).Value
        Next j
    Next i
End Sub

Option Explicit

'**************************************************************************'
'*
'* 関数名：シートクリア
'*
'* 形式：SheetClr(Sheet,Row1,Colum1,Row2,Colum2)
'*
'* 機能概要
'*
'* 指定された範囲以外のセルの文字を消す
'*
'* 引数
'* Sheet as Variant :シート番号
'* Row1 as Long ：文字をクリアしない行の初め
'* Colum1 as Long ：文字をクリアしない列の初め
'* Row2 as Long ：文字をクリアしない行の終わり
'* Colum2 as Long ：文字をクリアしない列の終わり
'*
'* 戻り値
'* True : 成功
'* False :　失敗
'*
'* 作成者
'* 作成日付
'*
'**************************************************************************'
Public Function SheetClr(ByVal Sheet As String, ByVal Row1 As Long, ByVal Colum1 As Long, ByVal Row2 As Long, ByVal Colum2 As Long) As Boolean

    Dim WkMaxRow As Long
    Dim WkMaxColum As Long
    Dim myRange As Range

    SheetClr = False

    '***入力チェック
    If Row1 > Row2 Or Colum1 > Colum2 Then Exit Function

    '***シートの選択
    With ThisWorkbook.Sheets(Sheet)
        .Activate
        '*****シートの使用範囲を取得
        Set myRange = .UsedRange
        WkMaxColum = myRange.Column + myRange.Columns.Count - 1
        WkMaxRow = myRange.Row + myRange.Rows.Count - 1
        Set myRange = Nothing

        '*****指定範囲以外をクリアする
        If Colum1 > 1 Then
            .Range(Cells(1, 1), Cells(WkMaxRow, Colum1 - 1)).ClearContents
            .Range(Cells(1, 1), Cells(WkMaxRow, Colum1 - 1)).Font.ColorIndex = 0
        End If
        If Row1 > 1 Then
            .Range(Cells(1, 1), Cells(Row1 - 1, WkMaxColum)).ClearContents
            .Range(Cells(1, 1), Cells(Row1 - 1, WkMaxColum)).Font.ColorIndex = 0
        End If
        If Colum2 < WkMaxColum Then
            .Range(Cells(1, Colum2 + 1), Cells(WkMaxRow, WkMaxColum)).ClearContents
            .Range(Cells(1, Colum2 + 1), Cells(WkMaxRow, WkMaxColum)).Font.ColorIndex = 0
        End If
        If Row2 < WkMaxRow Then
            .Range(Cells(Row2 + 1, 1), Cells(WkMaxRow, WkMaxColum)).ClearContents
            .Range(Cells(Row2 + 1, 1), Cells(WkMaxRow, WkMaxColum)).Font.ColorIndex = 0
        End If
    End With
    SheetClr = True
End Function

'***********************************************************************
'*
'* 形式： FNSearch
'* 機能：指定されたフォルダ配下のファイルを検索し，ファイル名を抽出する
'* 引数
'* Folder ：検索対象フォルダ
'* Fullpath : 抽出したファイルのファイル名を格納する(フルパス)
'* Fname : 抽出したファイルのファイル名を格納する(パス無し)
'* SerchObj : ファイル名の指定
'* SubFolder : サブフォルダも検索するか
'* 戻り値
'* ファイルがある場合：True
'* ファイルがない場合：False
'*
'* 作成者
'* 作成日付
'*
'**************************************************************************
Public Function FNSearch( _

            folder As String, _
            fullPath() As String, _
            fileName() As String, _
            Optional searchObj As String, _
            Optional subFolder As Boolean) As Boolean
    Dim wkFN As String
    Dim wkTxt As String
    Dim i As Long, j As Long
    Dim foundFiles As Collection

    On Local Error Resume Next
    FNSearch = False

    Set foundFiles = FileSearch(folder, searchObj, subFolder)

    ReDim fullPath(foundFiles.Count)
    ReDim fileName(foundFiles.Count)

    For i = 1 To foundFiles.Count
        fullPath(i) = foundFiles.Item(i)
        fileName(i) = getFileName(foundFiles.Item(i))
    Next i

    FNSearch = True
End Function

Private Function FileSearch( _

        folder As String, _
        Optional searchObj As String, _
        Optional subFolder As Boolean) As Collection

    Dim foundFiles As Collection

    ' 再帰探索を開始
    Set foundFiles = New Collection

    Call FileSearchRepeat(folder, foundFiles, searchObj, subFolder)

    ' 返り値
    Set FileSearch = foundFiles

End Function

' フォルダの再帰で呼び出される関数
Private Sub FileSearchRepeat( _

        folderPath As String, _
        foundFiles As Collection, _
        Optional searchObj As String, _
        Optional subFolder As Boolean)
    Dim fso As FileSystemObject
    Dim target_folder As folder, sub_folder As folder
    Dim objFile As Object

    Set fso = New FileSystemObject
    Set target_folder = fso.GetFolder(folderPath)

    If subFolder Then
        ' サブフォルダに再帰
        For Each sub_folder In target_folder.SubFolders
            Call FileSearchRepeat(sub_folder.Path, foundFiles, searchObj, subFolder)
        Next sub_folder
    End If

    ' ファイル
    For Each objFile In target_folder.Files
        With objFile

            ' 検索条件にマッチするか
            If searchObj = "" Or .Name Like searchObj Then

                ' 登録
                foundFiles.Add Item:=.Path
            End If

        End With
    Next objFile

    ' このフォルダと子フォルダの処理が終了
    Set fso = Nothing

End Sub

Public Function getFileName(fullPath As String) As String

    Dim result As String
    Dim wklen As Long
    Dim wkFP As Long
    Dim wkFPB As Long

    wklen = Len(fullPath)
    wkFP = 0
    Do While 1
        wkFPB = wkFP
        wkFP = InStr(wkFP + 1, fullPath, "\")
        If wkFP = 0 Then Exit Do
    Loop
    getFileName = Right(fullPath, wklen - wkFPB)
End Function

Option Explicit

Private Const FOLDER_ROW = 5
Private Const FOLDER_COL = 3

Public Sub OutputListButton_Click()

    Call 一覧化(Cells(FOLDER_ROW, FOLDER_COL).Value)

    MsgBox "完了しました。"
End Sub

Public Sub SelectFolderButton_Click()

    Dim wkFolder As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then
            wkFolder = .SelectedItems(1)
            Cells(FOLDER_ROW, FOLDER_COL).Value = wkFolder
            Cells(FOLDER_ROW, FOLDER_COL).Select
            ActiveSheet.Hyperlinks.Add Anchor:=Selection, address:=Cells(FOLDER_ROW, FOLDER_COL).Value
        End If
    End With
End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 ＞    With ThisWorkbook.Worksheets(1)
 ＞        j = .UsedRange.Row + .UsedRange.Rows.Count - 1
 ＞        For i = 9 To j
 ＞            If .Cells(i, 3).Value <> "" _
 ＞             And .Cells(i, 4).Value <> "" _
 ＞             And .Cells(i, 5).Value <> "" Then
 ＞                sheetNames.Add .Cells(i, 3).Value
 ＞                addresses.Add .Cells(i, 4).Value
 ＞                itemNames.Add .Cells(i, 5).Value
 ＞            End If
 ＞        Next i
 ＞    End With

ここが、1つ目のシートに対する処理のようですね。（少し前にSheets(1).Activateしてる箇所も含めるか…）
この1の部分を変数にして、1からSheets.CountまでForループで回せば良いように見えます。
（???） 2015/04/14(火) 09:07

ありがとうございます

Public Sub OutputListButton_Click()
Dim m As Integer

For m = 1 To Sheets.Count

    Sheets(Sheets(m).Name).Select
    Call 一覧化(Cells(FOLDER_ROW, FOLDER_COL).Value)

Next m

  On Error Resume Next
MsgBox "完了しました。"

End Sub

上記のように訂正してみたのですが、一覧が横に伸びてしまいます。。。
（たけさん） 2015/04/14(火) 16:53

コメント返信：

[ 一覧(最新更新順) ]

[[20150414014714]] 『複数ブックの複数シートから一覧を作成する』（たけさん） ページの最後に飛ぶ

[[20150414014714]]　『複数ブックの複数シートから一覧を作成する』（たけさん）　ページの最後に飛ぶ