public sub CopyCellFromBook

Dim filename, msg, bookname As String

Dim k, i, r As Long

Dim lastrow As Long

bookname = ThisWorkbook.Name

filename = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls),*.xls,",",") FilterIndex:=0, Title:="Select the workbook to copy", MultiSelect:=True)

If Not IsArray(filename) Then

MsgBox "Please select the workbook"

Exit Sub

End If

r = 2

For i = LBound(filename) To UBound(filename)

Workbooks.Open filename:=filename(i), Editable:=False

lastrow = Workbooks(2).Sheets(1).UsedRange.Rows.Count

For k = 2 To lastrow

If Workbooks(2).Sheets(1).Cells(k, 1) <> """ Then

Workbooks(1).Sheets(1).Cells(r, 1) = Workbooks(2).Sheets(1).Cells(k, 1)

Workbooks(1). Cells(k, 2)

Workbooks(1).Sheets(1).Cells(r, 3) = Workbooks(2).Sheets(1).Cells(k, 3)

r = r + 1

End If

Next k

Next i

Workbooks(2).Close

end sub