Macro to copy data from a set of excel files

[Sreejesh Menon]

i need to copy specific cell from a set of files inisde a folder and need to be pasted one below other,

folder. e:\billing\bill\imported
cells to copy j4, b5, j10, c4
and j4 value to be pasted in a column of result sheet one below another, b5 on b column, j10 on c column and following. please help me

[Excel Fox]

Sreejesh, is this only one folder, or does it include sub folders also? will there be excel workbooks only in that folder? and what about the master workbook? will this also be inside this folder?

[Sreejesh Menon]

it is only one folder, no sub folder and only excel work books. master also inside same folder

[Admin]

Hi Sreejesh,

Welcome to ExcelFox !!

try this

Sub kTest()
    
    Dim wbkSource   As Workbook
    Dim wbkMaster   As Workbook
    Dim wksMaster   As Worksheet
    Dim Dest        As Range
    Dim FName       As String
    Dim i           As Long
    Dim k(), x
    
    '// User settings
    Const MyFolder = "E:\billing\bill\imported\"
    Const MyCells = "J4,B5,J10,C4"
    Const MasterSht = "Sheet1"
    'End
    
    If Len(Dir(MyFolder, vbDirectory)) Then
        Set wbkMaster = ThisWorkbook
        On Error Resume Next
        Set wksMaster = wbkMaster.Worksheets(MasterSht)
        If Err.Number <> 0 Then
            MsgBox "Master sheet '" & MasterSht & "' couldn't found", vbInformation
            Err.Clear
            Exit Sub
        End If
        On Error GoTo 0
        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
        Set Dest = wksMaster.Range("a" & wksMaster.Rows.Count).End(3)(2)
        x = Split(MyCells, ",")
        ReDim k(UBound(x))
        
        FName = Dir(MyFolder & "*.xls*")
        Do While FName <> vbNullString
            If FName <> wbkMaster.Name Then
                Set wbkSource = Workbooks.Open(MyFolder & FName, 0)
                With wbkSource.Worksheets(1)
                    For i = 0 To UBound(x)
                        k(i) = .Range(CStr(x(i))).Value
                    Next
                End With
                wbkSource.Close 0
                Set wbkSource = Nothing
                Dest.Resize(, UBound(x) + 1) = k
                Set Dest = Dest(2)
            End If
            FName = Dir()
        Loop
    End If
    With Application
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
    
End Sub

[Sreejesh Menon]

this is working thanks a lot

[Admin]

You are welcome and thanks for the feedback