PDA

View Full Version : Adding header data during data extraction



vbjgd
09-12-2011, 06:24 AM
I am totally new to VBA and require help to modify this code. The code reads specific cells from different workbooks from a root folder and copies it into one single worksheet for analysis.
My objective is to create a pivot table and analyze the data but I require headers to do it.
Right now all the data is copied from A1 down. How to modify this code such that in . The following header data is copied in A1 thru F1 and the data gets copied from A2:F2.
A B C D E F G
Project | Desc | Task Name | Code | Hours | Discipline |filename

Any help will be greatly appreciated.

Sub Consolidate_Trail()
Dim wbkDst As Workbook
Dim wbkSrc As Workbook
Dim WsDst As Worksheet
Dim WsSrc As Worksheet
Dim fso, f, fs, f1
Dim I As Integer

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder("C:\Documents and Settings\vv\Desktop\MPI")
Set fs = f.Files
I = 1
For Each f1 In fs
If Right(f1.Name, 3) = "xls" Then
Set wbkSrc = Workbooks.Open("C:\Documents and Settings\vv\Desktop\MPI" & "\" & f1.Name)
Set wbkDst = ThisWorkbook
Set WsDst = wbkDst.ActiveSheet
Set WsSrc = wbkSrc.ActiveSheet

WsDst.Range("A" & I) = WsSrc.Range("A8")
WsDst.Range("B" & I) = WsSrc.Range("F8")
WsDst.Range("C" & I) = WsSrc.Range("K3")
WsDst.Range("D" & I) = WsSrc.Range("J7")
WsDst.Range("E" & I) = WsSrc.Range("K8")
WsDst.Range("F" & I) = WsSrc.Range("P20")
WsDst.Range("G" & I) = WsSrc.Range("P21")
WsDst.Range("H" & I) = WsSrc.Range("P22")
WsDst.Range("I" & I) = WsSrc.Range("P22")
WsDst.Range("J" & I) = WsSrc.Range("P23")
WsDst.Range("K" & I) = WsSrc.Range("P24")
WsDst.Range("L" & I) = WsSrc.Range("P25")
WsDst.Range("M" & I) = WsSrc.Range("P26")
WsDst.Range("N" & I) = WsSrc.Range("P28")
WsDst.Range("O" & I) = f1.Name
wbkSrc.Close False
I = I + 1
End If
Next
End Sub

Bob Phillips
09-12-2011, 06:43 AM
Sub Consolidate_Trail()
Dim wbkDst As Workbook
Dim wbkSrc As Workbook
Dim WsDst As Worksheet
Dim WsSrc As Worksheet
Dim fso, f, fs, f1
Dim I As Integer

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder("C:\Documents and Settings\vv\Desktop\MPI")
Set fs = f.Files
wsDst.Range("A1:G1").Value = Array("Project", "Desc", "Task Name", "Code", "Hours", "Discipline", "filename")
I = 2
For Each f1 In fs
If Right(f1.Name, 3) = "xls" Then
Set wbkSrc = Workbooks.Open("C:\Documents and Settings\vv\Desktop\MPI" & "\" & f1.Name)
Set wbkDst = ThisWorkbook
Set WsDst = wbkDst.ActiveSheet
Set WsSrc = wbkSrc.ActiveSheet

WsDst.Range("A" & I) = WsSrc.Range("A8")
WsDst.Range("B" & I) = WsSrc.Range("F8")
WsDst.Range("C" & I) = WsSrc.Range("K3")
WsDst.Range("D" & I) = WsSrc.Range("J7")
WsDst.Range("E" & I) = WsSrc.Range("K8")
WsDst.Range("F" & I) = WsSrc.Range("P20")
WsDst.Range("G" & I) = WsSrc.Range("P21")
WsDst.Range("H" & I) = WsSrc.Range("P22")
WsDst.Range("I" & I) = WsSrc.Range("P22")
WsDst.Range("J" & I) = WsSrc.Range("P23")
WsDst.Range("K" & I) = WsSrc.Range("P24")
WsDst.Range("L" & I) = WsSrc.Range("P25")
WsDst.Range("M" & I) = WsSrc.Range("P26")
WsDst.Range("N" & I) = WsSrc.Range("P28")
WsDst.Range("O" & I) = f1.Name
wbkSrc.Close False
I = I + 1
End If
Next
End Sub

vbjgd
09-12-2011, 06:54 AM
Thanks fro your quick reply but
Set fs =f.Files wsDst.Range("A1:G1").Value = Array("Project", "Desc",
"Task Name", "Code", "Hours", "Discipline", "filename") I = 2 For Each f1 In fs


this line is displayed in red when compiling it says syntax error in this line.

Bob Phillips
09-12-2011, 06:58 AM
That should be 2 lines, breaking at wsDst.

vbjgd
09-12-2011, 08:14 AM
this is what i have


Sub Consolidate_Trail()
Dim wbkDst As Workbook
Dim wbkSrc As Workbook
Dim WsDst As Worksheet
Dim WsSrc As Worksheet
Dim fso, f, fs, f1
Dim I As Integer

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder("C:\Documents and Settings\vv\Desktop\MPI")
Set fs = f.Files
WsDst.Range("A1:G1").Value = Array("Project", "Desc", "Task Name", "Code", "Hours", "Discipline", "filename")
I = 2
For Each f1 In fs

If Right(f1.Name, 3) = "xls" Then
Set wbkSrc = Workbooks.Open("C:\Documents and Settings\vv\Desktop\MPI" & "\" & f1.Name)
Set wbkDst = ThisWorkbook
Set WsDst = wbkDst.ActiveSheet
Set WsSrc = wbkSrc.ActiveSheet

WsDst.Range("A" & I) = WsSrc.Range("A8")
WsDst.Range("B" & I) = WsSrc.Range("F8")
WsDst.Range("C" & I) = WsSrc.Range("K3")
WsDst.Range("D" & I) = WsSrc.Range("J7")
WsDst.Range("E" & I) = WsSrc.Range("K8")
WsDst.Range("F" & I) = WsSrc.Range("P20")
WsDst.Range("G" & I) = WsSrc.Range("P21")
WsDst.Range("H" & I) = WsSrc.Range("P22")
WsDst.Range("I" & I) = WsSrc.Range("P22")
WsDst.Range("J" & I) = WsSrc.Range("P23")
WsDst.Range("K" & I) = WsSrc.Range("P24")
WsDst.Range("L" & I) = WsSrc.Range("P25")
WsDst.Range("M" & I) = WsSrc.Range("P26")
WsDst.Range("N" & I) = WsSrc.Range("P28")
WsDst.Range("O" & I) = f1.Name
wbkSrc.Close False
I = I + 1
End If
Next
End Sub


for each is there a closing statement for this. i am getting

Run time error 91 object variable or with block variable not set.

Bob Phillips
09-12-2011, 08:30 AM
See if this is better




Sub Consolidate_Trail()
Dim wbkDst As Workbook
Dim wbkSrc As Workbook
Dim WsDst As Worksheet
Dim WsSrc As Worksheet
Dim fso, f, fs, f1
Dim I As Integer

Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder("C:\test") 'Documents and Settings\vv\Desktop\MPI")
Set fs = f.Files
Set wbkDst = ThisWorkbook
Set WsDst = wbkDst.ActiveSheet
WsDst.Range("A1:G1").Value = Array("Project", "Desc", "Task Name", "Code", "Hours", "Discipline", "filename")
I = 2
For Each f1 In fs

If Right(f1.Name, 3) = "xls" Then
Set wbkSrc = Workbooks.Open("C:\Documents and Settings\vv\Desktop\MPI" & "\" & f1.Name)
Set WsSrc = wbkSrc.ActiveSheet

WsDst.Range("A" & I) = WsSrc.Range("A8")
WsDst.Range("B" & I) = WsSrc.Range("F8")
WsDst.Range("C" & I) = WsSrc.Range("K3")
WsDst.Range("D" & I) = WsSrc.Range("J7")
WsDst.Range("E" & I) = WsSrc.Range("K8")
WsDst.Range("F" & I) = WsSrc.Range("P20")
WsDst.Range("G" & I) = WsSrc.Range("P21")
WsDst.Range("H" & I) = WsSrc.Range("P22")
WsDst.Range("I" & I) = WsSrc.Range("P22")
WsDst.Range("J" & I) = WsSrc.Range("P23")
WsDst.Range("K" & I) = WsSrc.Range("P24")
WsDst.Range("L" & I) = WsSrc.Range("P25")
WsDst.Range("M" & I) = WsSrc.Range("P26")
WsDst.Range("N" & I) = WsSrc.Range("P28")
WsDst.Range("O" & I) = f1.Name
wbkSrc.Close False
I = I + 1
End If
Next
End Sub

vbjgd
09-12-2011, 08:36 AM
it worked like a charm. thanks a lot. i have been hunting for this solution for quite a while.

vbjgd
09-12-2011, 01:44 PM
one last step
How to modify this code to ensure that the entire worksheet contents are cleared when the user presses the button to run this procedure. I want to ensure that the copying is done on a clean slate. Currently I am selecting all the cells and deleting the data.

thanks for your time and inputs

Bob Phillips
09-12-2011, 02:03 PM
Add

WsDst.UsedRange.ClearContents

before the For loop.