.Range("I" & j & ":I" & j + 384)
Sub RXT() Dim i%, n%, m%, j%, x% Dim wb As Workbook Dim ws As Worksheet Dim mypath$, myname$ m = 6 i = 1 j = 6 arr = Array("Black", "W", "R", "G", "B", "C", "m", "Y") arr1 = Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12") dataNo = Array("3", "4", "6", "7", "9", "10", "13", "14", "16", "17", "19", "20", "24", "25", "27", "28", "30", "31", "34", "35", "37", "38", "40", "41", "44", "45", "46", "47", "48", "50", "51", "54", "55", "57", "58", "60", "61", "64", "65", "67", "68", "70", "71", "74", "75", "77", "78", "80", "81", "84", "85", "87", "88", "90", "91", "94", "95", "97", "98", "100", "101", "104", "105", "107", "108", "110", "111", "113", "114", "115", "116", "117", "118", "120", "121", "124", "125", "127", "128", "130", "131", "134", "135", "137", "138", "140", "141", "144", "145", "147", "148", "150", "151", "154", "155", "157", "158", "160", "161") Application.ScreenUpdating = False Application.DisplayAlerts = False mypath = ThisWorkbook.Path & "\" myname = Dir(mypath & "*.csv") With Worksheets(1) .UsedRange.Offset(5, 3).Clear End With Do While myname <> "" If myname <> ThisWorkbook.Name Then Set wb = GetObject(mypath & myname) With wb With .Worksheets(1) 'm = ThisWorkbook.Worksheets(1).Range("D65536").End(xlUp).Row + 1 'i = .Range("A65536").End(xlUp).Row .Range("B2:T97").Copy ThisWorkbook.Worksheets(1).Cells(m, 4) 'ThisWorkbook.Worksheets(1).Cells(m, 4).PasteSpecial xlPasteValues ThisWorkbook.Worksheets(1).Range(Cells(m, 1), Cells(m + 95, 1)) = Mid(myname, 1, 50) End With .Close False End With End If m = m + 96 myname = Dir Loop With ThisWorkbook For n = 0 To 7 .Worksheets(1).Range("A5:BI485").AutoFilter Field:=3, Criteria1:=Array(arr(n)), Operator:=xlFilterValues For i = 1 To 12 x = dataNo(n * 12 + i - 1) .Worksheets(1).Range("A5:BI485").AutoFilter Field:=2, Criteria1:=Array(arr1(i - 1)), Operator:=xlFilterValues .Worksheets(1).Range("I" & j & ":I" & j + 384).Copy .Worksheets(2).Cells(43, x).PasteSpecial Paste:=xlPasteValues j = j + 8 Next Next End With Application.ScreenUpdating = True End Sub