VBA to copy specified cells from all the files in a folder

R

rakeshplb

New Member
Joined
Apr 3, 2009
Messages
31
Hi All,

I have a folder "D:\Documents and Settings\Rakesh", which has many .xls files. Each file has a sheet called 'Cover Note'. I want to copy cells B2, C2, D4 and F3 from 'Cover Note' of each file.

These cells should be pasted in the current sheet - row 2 onwards. First cell of each row should have the source file name.

Please, can anybody help me. Thanks.

Rakesh
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Sort by date Sort by votes
try
Code: 
Sub test()
Dim myDir As String, fn As String, i As Long
myFir = "D:\Documents and Settings\Rakesh\"
fn = Dir(myDir & "*.xls")
Do While fn <> ""
    i = i + 1
    myFormula = "='" & myDir & "[" & fn & "]Cover Note'!"
    With ThisWorkbook.Sheets(1).Cells(i, 1)
        .Value = fn
        .Offset(,1).Resize(, 4).Formula = _
        Array(myFormula & "b2", myFormula & "c2", _
            myFormula & "d4", myFormula & "f3")
    End With
    fn = Dir
Loop
End Sub
 
Upvote 0
Thanks Seiya, this works.

Can you modify this to work for all the sub folders also.

And can we have a cell where I can put the folder path, otherwise I have to chage the code each time.
 
Upvote 0
rakeshplb said:
Thanks Seiya, this works.

Can you modify this to work for all the sub folders also.

And can we have a cell where I can put the folder path, otherwise I have to chage the code each time.
Click to expand...
You should have mentioned this in the first stage.
Rich (BB code): 
Private myList(), myN As Long
 
Sub test()
Dim myDir As String
With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = True Then
        myDir =  .SelectedItems(1)
    Else
        Exit Sub
    End If
End With
myN = 0
SearchAllFiles myDir, "*.xls", True
If myN > 0 Then
    DoTheJob
Else
    MsgBox "No file found"
End If
End Sub
 
Private Sub SearchAllFiles(ByVal myDir As String, _
          ByVal myFileName As String, SubFolder As Boolean)
Dim fso As Object, myFile As Object, myFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.GetFolder(myDir).Files
    If myFile.Name Like myFile Then
        myN = myN + 1
        ReDim Preserve myList(1 To 2, 1 To myN)
        myList(1, myN) = myDir : myList(2, myN) = myFlie.Name
    End If
Next
If SubFolder Then
    for Each myFolder In fso.GetFolder(myDir).SubFolders
        SearchAllFiles myDir & "\" & myFolder.Name, myFileName, True
    Next
End If
End Sub
 
Private Sub DoTheJob()
 
I have no time left today, do this for yourself, otherwise wait until Tue.
 
Upvote 0
This code is not working. it says no file found.

can some one suggest me a better working and complete code.

Thanks
 
Upvote 0
Code: 
Option Explicit
Public strSourceFldr As String
Public EachFile As Object
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public strSheetName As String
Public strSrcCell1 As String
Public strSrcCell2 As String
Public strSrcCell3 As String
Public strSrcCell4 As String
Public intStartCell As Integer
Sub DataCopy()
    strSourceFldr = "D:\Documents and Settings\Rakesh\"
    strSheetName = "Sheet1"
    strSrcCell1 = "B2"
    strSrcCell2 = "C2"
    strSrcCell3 = "D4"
    strSrcCell4 = "F3"
    intStartCell = 2
    Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set objFolder = objFSO.GetFolder(strSourceFldr)
    For Each EachFile In objFolder.Files
        If LCase(objFSO.GetExtensionName(EachFile)) = "xls" Then
            ProcessFile EachFile
        End If
    Next
    ProcessSubFolder objFSO.GetFolder(strSourceFldr)
End Sub
Sub ProcessFile(ByRef ThisFile As Object)
    Dim Cell1, Cell2, Cell3, Cell4
    Set objFile = objFSO.GetFile(ThisFile)
    Workbooks.Open ThisFile
    Cell1 = Range(strSrcCell1).Value
    Cell2 = Range(strSrcCell2).Value
    Cell3 = Range(strSrcCell3).Value
    Cell4 = Range(strSrcCell4).Value
    ActiveWorkbook.Close
    Worksheets(1).Cells(intStartCell, 1) = ThisFile.Name
    Worksheets(1).Cells(intStartCell, 2) = Cell1
    Worksheets(1).Cells(intStartCell, 3) = Cell2
    Worksheets(1).Cells(intStartCell, 4) = Cell3
    Worksheets(1).Cells(intStartCell, 5) = Cell4
    Worksheets(1).Cells(intStartCell, 6) = ThisFile.Path
    intStartCell = intStartCell + 1
End Sub
Sub ProcessSubFolder(ByRef ThisFolder As Object)
    Dim SubFolder
    For Each SubFolder In ThisFolder.SubFolders
        Set objFolder = objFSO.GetFolder(SubFolder.Path)
        For Each EachFile In objFolder.Files
            If LCase(objFSO.GetExtensionName(EachFile)) = "xls" Then
                ProcessFile EachFile
            End If
        Next
        ProcessSubFolder objFolder
    Next
End Sub
 
Upvote 0
Thanks Nirvana. It works.

Just a modification if you can do.
Instead of hard coding the folder path, can we paste the path in some cell and macro should refer to it. Can you do it for me please. Thank you very much.
 
Upvote 0
Put it in cell N1 and run the code. Just one thing to note. The folder path should always end with \ something like this

D:\Documents and Settings\

Code: 
Option Explicit
Public strSourceFldr As String
Public EachFile As Object
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public strSheetName As String
Public strSrcCell1 As String
Public strSrcCell2 As String
Public strSrcCell3 As String
Public strSrcCell4 As String
Public intStartCell As Integer
Sub DataCopy()
    strSourceFldr = Worksheets(1).Cells(1, 14)
    strSheetName = "Sheet1"
    strSrcCell1 = "B2"
    strSrcCell2 = "C2"
    strSrcCell3 = "D4"
    strSrcCell4 = "F3"
    intStartCell = 2
    Set objFSO = CreateObject("Scripting.Filesystemobject")
    Set objFolder = objFSO.GetFolder(strSourceFldr)
    For Each EachFile In objFolder.Files
        If LCase(objFSO.GetExtensionName(EachFile)) = "xls" Then
            ProcessFile EachFile
        End If
    Next
    ProcessSubFolder objFSO.GetFolder(strSourceFldr)
End Sub
Sub ProcessFile(ByRef ThisFile As Object)
    Dim Cell1, Cell2, Cell3, Cell4
    Set objFile = objFSO.GetFile(ThisFile)
    Workbooks.Open ThisFile
    Cell1 = Range(strSrcCell1).Value
    Cell2 = Range(strSrcCell2).Value
    Cell3 = Range(strSrcCell3).Value
    Cell4 = Range(strSrcCell4).Value
    ActiveWorkbook.Close
    Worksheets(1).Cells(intStartCell, 1) = ThisFile.Name
    Worksheets(1).Cells(intStartCell, 2) = Cell1
    Worksheets(1).Cells(intStartCell, 3) = Cell2
    Worksheets(1).Cells(intStartCell, 4) = Cell3
    Worksheets(1).Cells(intStartCell, 5) = Cell4
    Worksheets(1).Cells(intStartCell, 6) = ThisFile.Path
    intStartCell = intStartCell + 1
End Sub
Sub ProcessSubFolder(ByRef ThisFolder As Object)
    Dim SubFolder
    For Each SubFolder In ThisFolder.SubFolders
        Set objFolder = objFSO.GetFolder(SubFolder.Path)
        For Each EachFile In objFolder.Files
            If LCase(objFSO.GetExtensionName(EachFile)) = "xls" Then
                ProcessFile EachFile
            End If
        Next
        ProcessSubFolder objFolder
    Next
End Sub
 
Upvote 0
Thanks Nirvana, This works like magic.

I want to put the condition here - the code should only copy cells if the sheet is named specifically such as "Reconciliation", if not named as this, they should be put in a saperate list/folder so they can be identified. Is it possible?

Many thanks for your great help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA to clear all date in columns A2 to AC in the destination file, then copy the data from the same columns from all files in a folder
Replies
1
Views
131
jdhfch
J
F
  • Solved
VBA to open all files in a folder, put the file's name in a cell and copy it to another opened workbook
Replies
5
Views
228
feni1388
F
KlausW
  • Question
browse to folders and subfolders an copy cell
Replies
0
Views
231
KlausW
KlausW
D
  • Question
VBA - Open Files then copy specific cells into a new row.
Replies
1
Views
253
dhubz
D
S
  • Solved
For each row, create new folder based on single cell value, then save exported XML doc to matching folder.
Replies
3
Views
238
shand
S

Forum statistics

Threads
1,216,077
Messages
6,128,684
Members
449,463
Latest member
Jojomen56

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top