Option Explicit Sub test2() Dim a As Object Dim p As String Dim v Dim f As String Dim i As Long Dim flg As Boolean Set a = CreateObject("system.collections.arraylist") p = ThisWorkbook.path & "\" f = Dir(p & "*.xlsx") Do While f <> "" With Workbooks.Open(p & f, ReadOnly:=True) v = .Sheets(1).Cells(1).CurrentRegion.Value flg = False If v(1, 7) = "School" Then flg = True For i = 2 To UBound(v) a.Add Array(f, IIf(v(i, 3) = "M", v(i, 3), v(i, 4)), v(i, 5), _ IIf(flg, Empty, v(i, 6)), IIf(flg, v(i, 7), Empty) _ , IIf(flg, Empty, v(i, 8)), IIf(flg, v(i, 8), Empty)) Next .Close End With f = Dir() Loop With ThisWorkbook.Sheets(1) .UsedRange.Offset(2).ClearContents .Cells(3, 1).Resize(a.Count, 7).Value = _ Application.Transpose(Application.Transpose(a.toarray)) End With End Sub