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

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
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

P
  • Solved
VBA to insert filename in a new column for all files in a folder
Replies
2
Views
134
psion2600
P
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
1K
Micron
M
H
  • Question Question
selecting a folder and copying all files into another folder
2 3
Replies
20
Views
514
Holley
H
G
  • Question Question
remove columns from multiple Excel-files in a folder
Replies
5
Views
342
gjvv
G
S
  • Solved
Gathering Data From Multiple Files in Same Folder in Particular Range
9 10 11
Replies
105
Views
2K
shah0101
S

Forum statistics

Threads
1,224,885
Messages
6,181,588
Members
453,055
Latest member
cope7895

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