PDA

View Full Version : Macro to copy data rom all the files in folder and paste in single sheet



Subramanian
08-10-2016, 01:23 PM
Hi,

I am just working with below

i.e I will have a folder that will have say 10 files( all the files will have required data in fixed cell) that i will require data from cell A1, A2, A3 of all the sheet in single file.
and the above files will be overwritten with new file every day or even on same day as an update

Currently i made a 11th file in the folder with a formula (referring each cell by link)to pick the data in single sheet from each data file. But it does not work when user over write formula, same works only when i open and close the overwritten file.

Also tries recording macro but they same gives a very long code and will also not be accurate 10 files was an example folder may contain 70 to 100 files too.

Could some one please suggest a VBA to do all the above task automatically instead using a formula to refer a cell.

Thanks in advance,
Subramanian

Kenneth Hobs
08-11-2016, 05:08 AM
More details are needed.
e.g.
1. Get 3 values from Sheet1 in all files: a1, a2, a3
2. In master file, insert (1) data into next empty row defined by Sheet1 column A. If next empty is a4 then poke values for first file to a4, a5, a6.

Subramanian
08-11-2016, 12:57 PM
More details are needed.
e.g.
1. Get 3 values from Sheet1 in all files: a1, a2, a3
2. In master file, insert (1) data into next empty row defined by Sheet1 column A. If next empty is a4 then poke values for first file to a4, a5, a6.

Hi Kenneth,

Many thanks for looking into this.
Eg are as below.
In Folder i will have below files
Abc Account.xls
Pqr account.xls
Xzy account.xls
Master file.xlsm

Accounts file will have report date in A1, closing balance in B8, ledger balance in C10


Master file will have all account name in A column
I.e A1(Account Name)
A2= Abc account
A3 = Pqr account
A4 = xyz account

Report date in b column
B1(report date)
B2 = date of Abc account
B3 = date of pqr account
C3 = date of xyz account

Balance in c column
c1( closing Balance)
C2 - balance of abc
C3 - balance of pqr
c4 - balance of xyz

Ledger bal in d column
D1(ledger bal)
D2 - ledger bal of abc
D3 - ledger bal of pqr
D4 - ledger bal of xzy

Hopes this example helps you.
Many thank in advance

Kenneth Hobs
08-11-2016, 04:35 PM
Did you need a copy that includes formatting or just the raw value?

Getting the value is faster but may not show numeric formatting as you might expect. Of course since there are just a few cells to get in each file, formatting the master is easy enough.

Subramanian
08-12-2016, 12:00 AM
Hi Kenneth,

No issues, just will require value i.e if we copy manually from accounts will paste special only with values in master file . As master will be already formatted as per requirement.

Kenneth Hobs
08-12-2016, 06:42 AM
Modify Main() to suit. Change value of aPath to where your account XLSM files are at. Master or Activeworkbook (where data is imported/poked) can be in that folder or not. No other XLSM files are expected in aPath.

Account sheet is "Sheet1". Change as needed in call to GetValue().

Data from account files are imported/poked into first worksheet of master, ActiveWorkbook.

Comments show steps and other things like how to set the NumberFormat format if needed.


Sub Main()
Dim vv() As Variant, aPath As String, v As Variant, c As Range
Dim s() As String, a() As Variant, fso As Object

'Change value of aPath to suit your path to account files.
'aPath = "C:\Users\lenovo1\Dropbox\Excel\FileFolder\Accounts\"
aPath = ThisWorkbook.path & "\"

'Speed things up a bit as data is written to master file, ActiveWorkbook.
'On Error GoTo EndSub
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set fso = CreateObject("Scripting.FileSystemObject")

'Fill variant array with full paths to account "xlsm" files.
vv() = aFFs(aPath & "*.xlsm")
'MsgBox Join(vv, vbLf)

'Set first empty cell in column A, first Worksheet, in ActiveWorkbook, master file.
Set c = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)

'Fill first row in ActiveWorkbook, first Worksheet, with column headings, if needed in loop.
a() = Array("Account Name", "Report Date", "Closing Balance", "Ledger Balance")
If Worksheets(1).Range("A1").Value = "" Then Worksheets(1).Range("A1:D1").Value = a()

'Iterate filenames in vv() and fill ActiveWorkbook.
For Each v In vv()
'Skip master file in vv(), ThisWorkbook, if it is in the accounts folder.
If v = ThisWorkbook.FullName Then GoTo NextV
'Get the data from the account files in vv() and poke into ThisWorkbook.
'Account Name, from account filename:
c.Value = fso.GetBasename(v)
'Report Date, A1 in account file:
c.Offset(, 1).Value = GetValue(fso.GetParentFolderName(v), _
fso.GetFilename(v), "Sheet1", "A1")
'Set date format for Report Date:
'c.Offset(, 1).NumberFormat = "mm/dd/yyyy"
'Balance, B8 in account file:
c.Offset(, 2).Value = GetValue(fso.GetParentFolderName(v), _
fso.GetFilename(v), "Sheet1", "B8")
'Ledger, C10 in account file:
c.Offset(, 3).Value = GetValue(fso.GetParentFolderName(v), _
fso.GetFilename(v), "Sheet1", "C10")
'Get next empty Column A cell.
Set c = c.Offset(1)
NextV:
Next v

'Autofit columns A:D
Worksheets(1).Columns("A:D").AutoFit

EndSub:
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
Set fso = Nothing
End Sub




'http://www.vbaexpress.com/kb/getarticle.php?kb_id=454
'http://spreadsheetpage.com/index.php/tip/a_vba_function_to_get_a_value_from_a_closed_file/
'=GetValue("c:\files", "budget.xls", "Sheet1", "A1")
Function GetValue(path, File, sheet, ref)
' path = "d:\files"
' file = "budget.xls"
' sheet = "Sheet1"
' ref = "A1:R30"


Dim arg As String

If Right(path, 1) <> "\" Then path = path & "\"

If Dir(path & File) = "" Then
GetValue = "file not found"
Exit Function
End If

arg = "'" & path & "[" & File & "]" & sheet & "'!" & _
Range(ref).Range("a1").Address(, , xlR1C1)
GetValue = ExecuteExcel4Macro(arg)
End Function




'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant

Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long

If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If

a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
MsgBox myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function