ループ範囲

Question

の各ブックを通じてI列でExcelワークブックファイルのパスとファイル名を持つブックを持っている：

C:\D\Folder1\File1.xls 
C:\D\Folder2\File2.xls 
C:\D\Folder3\File3.xls 

各ファイルとそのファイルパスは、上記のようなディレクトリから引き出されます。

これらのワークブックの各

は、私はそうのような私のワークブックの隣接するセルにコピー＆ペーストしたいセルC15にメールアドレスが含まれています

C:D\\Folder1\File1.xls  email@email.com 
C:\D\Folder2\File2.xls  email@email.com 
C:\D\Folder3\File3.xls  email@email.com 

私のコードは、唯一のワークブックをチェックし、1つの電子メールアドレスをつかむ

セルD17内：

C:\D\Folder1\File1.xls  email@email.com 
C:\D\Folder2\File2.xls  
C:\D\Folder3\File3.xls 

リスト内の各ブックをループする方法を教えてください。

は、ここに私のコードです：

Sub SO() 

Dim parentFolder As String 

parentFolder = Range("F11").Value & "\" '// change as required, keep trailing slash 

Dim results As String 

results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & parentFolder & "*.*"" /S /B /A:-D").StdOut.ReadAll 

Debug.Print results 

'// uncomment to dump results into column A of spreadsheet instead: 
Range("D17").Resize(UBound(Split(results, vbCrLf)), 1).Value = WorksheetFunction.Transpose(Split(results, vbCrLf)) 
Range("Z17").Resize(UBound(Split(results, vbCrLf)), 1).Value = "Remove" 
'//----------------------------------------------------------------- 
'// uncomment to filter certain files from results. 
'// Const filterType As String = "*.exe" 
'// Dim filterResults As String 
'// 
'// filterResults = Join(Filter(Split(results, vbCrLf), filterType), vbCrLf) 
'// 
'// Debug.Print filterResults 
On Error GoTo errHandler 
Application.DisplayAlerts = False 
Application.EnableEvents = False 
Application.ScreenUpdating = False 


Dim app As New Excel.Application 
app.Visible = False 'Visible is False by default, so this isn't necessary 

Dim x As Workbook 
Dim y As Workbook 

'## Open both workbooks first: 
Set x = Workbooks.Open(Range("D17").Value) 
Set y = ThisWorkbook 

'Now, copy what you want from x: 
x.Worksheets(1).Range("C15").Copy 

'Now, paste to y worksheet: 
y.Worksheets(1).Range("U17").PasteSpecial xlPasteValues 

'Close x: 
x.Close 


Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.EnableEvents = True 

errHandler: 
Application.DisplayAlerts = False 
Application.EnableEvents = False 
Application.ScreenUpdating = False 

End Sub 

Answer 1

あなたの質問は（誰もがあなたのDir()ソリューションを与えている理由である）やや不明確です。

ワークシートにパス名とファイル名のリストがすでにあり、ワークシートの各行にそれらのファイルの特定のセル値を移入するだけでいいと思っています。毎回実際にワークブックを開くことなく（例：セル式で、ADO、ExecuteExcel4Macro()を使用して）これを行うには、いくつかの方法があります。これらのいずれかがあなたによく役立つでしょう。

私の個人的な好みは、エラー処理とテーブル名、シート名などを確認するために、さらに制御することができるので、ADOです。以下のコードは、ExecuteExcel4Macro()がどのように機能するかを示していますよりあなたに適しています）。コードの最初の行のワークシートの名前をシート名に変更し、2行目のファイル名の最初のセルの範囲アドレスを変更する必要があります。

Dim startCell As Range, fileRng As Range 
Dim files As Variant, values() As Variant 
Dim path As String, file As String, arg As String 
Dim r As Long, i As Long 

'Acquire the names of your files 
With ThisWorkbook.Worksheets("Sheet1") 'amend to your sheet name 
    Set startCell = .Range("F11") 'amend to start cell of file names 
    Set fileRng = .Range(startCell, .Cells(.Rows.Count, startCell.Column).End(xlUp)) 
End With 
files = fileRng.Value2 

'Size your output array 
ReDim values(1 To UBound(files, 1), 1 To 1) 

'Populate output array with values from workbooks 
For r = 1 To UBound(files, 1) 
    'Create argument to read workbook value 
    i = InStrRev(files(r, 1), "\") 
    path = Left(files(r, 1), i) 
    file = Right(files(r, 1), Len(files(r, 1)) - i) 
    arg = "'" & path & "[" & file & "]Sheet1'!R15C3" 
    'Acquire the value 
    values(r, 1) = ExecuteExcel4Macro(arg) 
Next 

'Write values to sheet 
fileRng.Offset(, 1).Value = values 

Answer 2

ヴィンセントGが言ったように、あなたのエラーハンドラが良くない、と（その迅速かつ使いやすい）ファイルをループする場合は、同様のDirを使用することができます。タスクを分割するほうが簡単かもしれません。私が予約したコードをいくつか修正しました。あなたが必要とするものをやると思います。あなたがそれを理解していない場合は、尋ねるだけです。

Sub DirectoryLoop() 
Dim FileName As String, FilePath As String, TargetValue As String, HomeFile As String 
HomeFile = "TestBook.xlsx" 
FilePath = "C:\" 
FileName = dir(FilePath & "\", vbNormal) 
Do While FileName <> "" 
    TargetValue = GetInfo(FileName, FilePath) 
    WriteInfo TargetValue, HomeFile 
    FileName = dir 
Loop 
End Sub 
Function GetInfo(ByRef TargetFile As String, ByRef Folder As String) As String 
    Workbooks.Open Folder & "\" & TargetFile 
    GetInfo = Workbooks(TargetFile).Worksheets(1).Range("D17").value 
    Workbooks(TargetFile).Close 
End Function 
Sub WriteInfo(ByRef TargetVal As String, HomeWorkbook As String) 
    With Workbooks(HomeWorkbook).sheets(1) 
     .Range("U" & .rows.count).End(xlUp).value = TargetVal 
    End With 
End Sub 

Answer 3

次のコードは動作するはずです。 Z列の削除で何をしたいのか分かりませんでしたので、すべての行にExcelファイルをコピーしました。

ここでは、アクティブシートがワークシート（1）であるとします。

Sub SO() 
    Dim parentFolder As String 
    Dim filename As String 
    Dim wb As Workbook 
    parentFolder = Range("F11").Value & "\" 

    'On Error GoTo errHandler 

    Application.ScreenUpdating = False 
    Application.DisplayAlerts = False 
    Application.EnableEvents = False 

    filename = Dir$(parentFolder & "*.*") 
    Dim currentRow As Long 
    currentRow = 17 
    Do While Len(filename) > 0 
     Cells(currentRow, 4).Value = filename ' 4 is U column 
     'this will fail if file is not excel file 
     Set wb = Workbooks.Open(parentFolder & filename) 
     Cells(currentRow, 21).Value = wb.Worksheets(1).Range("C15").Value ' 21 is U column 
     wb.Close 
     cells(currentRow,26).Value = "Remove" 
next_file: 
     filename = Dir$ 
     currentRow = currentRow + 1 
    Loop 

    Application.ScreenUpdating = True 
    Application.DisplayAlerts = True 
    Application.EnableEvents = True 

    Exit Sub 
errHandler: 
    'in case of error we skip and go to the next file. 
    Resume next_file 
End Sub 

Answer 4

さらに別の解決策：

Option Explicit 

'Modify as needed 
Const EXCELPATH = "C:\Temp\SO\" 
Const EXCELFILES = "*.xls" 
Const EMAILCELL = "D15" 
Const SHEETNAME = "Sheet1" 

Sub GetEmails() 
    Dim XL As Object  'Excel.Application 
    Dim WB As Object  'Excel.Workbooks 
    Dim WS As Object  'Excel.Worksheet 
    Dim theCell As Range 
    Dim theFile As String 
    Dim theExcelFile As String 

    Set XL = CreateObject("Excel.Application") 
    theFile = Dir(EXCELPATH & EXCELFILES) 
    Do While theFile <> "" 
     theExcelFile = EXCELPATH & theFile 
     Set WB = OpenWorkbook(XL, theExcelFile) 
     Set WS = WB.Sheets(SHEETNAME) 
    '* 
    '* Get the email address in EMAILCELL 
    '* 
    Set theCell = WS.Range(EMAILCELL) 
    Debug.Print "Email from " & theExcelFile & ": " & theCell.Value 
    '* 
    '* Handle the email address as desired 
    '* 
    '...... your code ..... 
    ' 
    theFile = Dir() 'Next file if any 
    Loop 
End Sub 
'****************************************** 
'* Return WB as Workbook object 
'* XL is an Excel application object 
'* 
Function OpenWorkbook(XL As Object, Filename As String) As Object 
    Dim i As Integer 

    Set OpenWorkbook = XL.Workbooks.Open(Filename) 
    OpenWorkbook.Activate 
    '* 
    '* Wait until the Excel file is open. 
    '* 
    i = 10 
    Do While IsFileOpen(Filename) = False 
     i = i - 1 
     If i = 0 Then Exit Do 
    Loop 
    If i = 0 Then MsgBox "Error opening Excel file:" & vbCrLf & Filename 
End Function 
'********************************************************************************************************************* 
'* Check if an Office file is open 
'* Reference: http://accessexperts.com/blog/2012/03/06/checking-if-files-are-locked 
'* Short story: "small" applications like Notepad do not lock opened files whereas Office applications do 
'* The below code tests if a file is locked 
'* 
Function IsFileOpen(Filename As String) As Boolean 
    Dim n As Integer 

    IsFileOpen = False 
    n = FreeFile() 'Next free 
    On Error GoTo Opened 

    Open Filename For Random Access Read Write Lock Read Write As #n 'Error if locked 
    Close n 'Not locked 
    Exit Function 

Opened: 
    IsFileOpen = True 
    On Error GoTo 0 
End Function