今後があるかもしれませんので、一応、アップします。お気に障られたら、ごめんなさい。 ・「cnt」文字（スラング）には問題があります。使われないほうがいいでしょう。 ・他の月もありそうなので、変数を使用されることをお勧めします。提示の例でいえば「s業務日誌月 = "01月"」を変更するコードにすれば、他の月にも適用できます。また、シート変数などを使えば効率化になるかもしれません。 Sub 一覧表作成() ''業務日誌のフォルダーと報告月を定義する。 Dim s業務日誌フォルダ As String, s業務日誌月 As String s業務日誌フォルダ = "C:\業務日誌\" s業務日誌月 = "01月" ''使用変数を定義する。 Dim MyWb As Workbook, MyWs As Worksheet, MyMonth As Worksheet ''自身のブック管理 Dim wb As Workbook, ws As Worksheet ''業務日誌のブック管理 Dim A As String, B As Range, iCount As Long ''環境変数を設定する。 Set MyWb = ThisWorkbook ''ブック Set MyWs = ActiveSheet ''「管理？」シート ※今回は不要か？ Set MyMonth = MyWb.Worksheets(s業務日誌月) ''業務日誌月 ''初の業務日誌ファイル名を取得する｡ A = Dir(s業務日誌フォルダ & "*業務日誌*.xlsm") ''業務日誌分を繰り返し、一覧を作成する。 Application.ScreenUpdating = False iCount = 0 Do While A <> "" ''管理情報有無の確認とパスワード位置を求める。 Set B = Range("B:B").Find(A, lookat:=xlWhole) If B Is Nothing Then ''業務日誌の管理情報がない場合のログか？なんでdebug分？ Debug.Print A & "はありません" 'MsgBox A & "はありあせん", vbCritical + vbOKOnly Else ''業務日誌をオープンする。 Set wb = Workbooks.Open(Filename:=s業務日誌フォルダ & A, Password:=B.Offset(0, 1).Value, ReadOnly:=True) ''業務日誌をコピーする（提示コード）。 iCount = iCount + 1 wb.Worksheets(s業務日誌月).Range("B1:J100").Copy MyMonth.Cells(iCount, "B").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False MyMonth.Cells(iCount, "B").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False ''※今回は意味ないね。削除か？ iCount = iCount + 100 ''次のコピー位置 ''業務日誌をクローズする。 Application.DisplayAlerts = False wb.Close SaveChanges:=False Application.DisplayAlerts = True End If ''次の業務日誌を取得する。ない場合は、空白が返る。 A = Dir() Loop ''環境変数を開放する。 Set MyWb = Nothing Set MyWs = Nothing Set MyMonth = Nothing Set wb = Nothing Set ws = Nothing Application.ScreenUpdating = True End Sub