PDA

View Full Version : Solved: Copy fixed 3 cells from multiple files with 1 or 2 or 3 sheets



jigar1276
08-30-2008, 04:56 AM
Hi Experts,

I have a folder containing many excel files with same format. I have written the code for opening each file and copying 3 cells (B3, E3 and E13) from each sheet of each file and paste it to "CheckPIdata.xls".

The code written is:

Sub CopyPIDATA()
'
'
Dim fso As Object, folder, filelist, file
Dim ws As Worksheet, wb As Workbook
Set fso = CreateObject("Scripting.filesystemobject")
Set folder = fso.getfolder("C:\Documents and Settings\baraijig\Desktop\pi")
Set filelist = folder.Files
i = 1
For Each file In filelist
Set wb = Workbooks.Open(folder & "\" & file.Name)
For Each ws In wb.Worksheets
i = i + 1
Workbooks("checkPIdata").Worksheets("Sheet1").Range("A" & i).Value = ws.Range("B3").Value
Workbooks("checkPIdata").Worksheets("Sheet1").Range("B" & i).Value = ws.Range("E3").Value
Workbooks("checkPIdata").Worksheets("Sheet1").Range("C" & i).Value = ws.Range("E13").Value
Workbooks(file.Name).Close
Next ws
Set ws = Nothing
Set file = Nothing
Next file
End Sub


The above code works fine. It is opening each file in the folder and copying data to "CheckPIdata.xls". The problem is that the data is copied only from first sheet of each file and not all the sheets of each files.

Filenames and sheetnames are not fixed.

Please help me to rectify my code so that it copies the data from each sheet instead of only one sheet.

Thanks in advance.

stanleydgrom
08-30-2008, 03:57 PM
jigar1276,

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Try changing the following lines of code:



Workbooks("checkPIdata").Worksheets(ws).Range("A" & i).Value = ws.Range("B3").Value
Workbooks("checkPIdata").Worksheets(ws).Range("B" & i).Value = ws.Range("E3").Value
Workbooks("checkPIdata").Worksheets(ws).Range("C" & i).Value = ws.Range("E13").Value




Have a great day,
Stan

rbrhodes
08-30-2008, 05:40 PM
Hi jigar1276,

Your problem is that you're closing the WB in the loop before it reads all sheets. Here's my version...


'Always a good idea
Option Explicit
Sub CopyPIDATA()
Dim i As Long
Dim fso As Object, folder, filelist, file
Dim ws As Worksheet, wb As Workbook
Set fso = CreateObject("Scripting.filesystemobject")
Set folder = fso.getfolder("C:\temp")
Set filelist = folder.Files

i = 1

For Each file In filelist
Set wb = Workbooks.Open(folder & "\" & file.Name)
For Each ws In wb.Worksheets
i = i + 1
'//Simplify by using 'With'
With Workbooks("checkPIdata.xls").Worksheets("Sheet1")
.Range("A" & i).Value = ws.Range("B3").Value
.Range("B" & i).Value = ws.Range("E3").Value
.Range("C" & i).Value = ws.Range("E13").Value
End With
'//NOT HERE!! Workbooks(file.Name).Close
Next ws

'//Moved out of ws loop so ALL sheets
' are done before wb is closed.
' This is the actual problem!!
Workbooks(file.Name).Close
Next file

'//Cleanup when done
Set wb = Nothing
Set ws = Nothing
Set fso = Nothing
Set file = Nothing
Set folder = Nothing
Set filelist = Nothing

End Sub

jigar1276
09-02-2008, 12:17 AM
Thanks rbrhodes, Its working fine now.

mdmackillop
09-02-2008, 12:20 AM
Check out this method (http://vbaexpress.com/kb/getarticle.php?kb_id=454) as well

jigar1276
09-02-2008, 02:41 AM
Thanks MD for upgrading my knowledge.