Macro to copy data from a set of excel files

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

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?

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

Hi Sreejesh,

Welcome to ExcelFox !!

try this

Code:

---

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

---

this is working thanks a lot

You are welcome and thanks for the feedback :cheers: