Macro to open each file in a folder copy specific cell, paste in workbook move onto next file.

[Haggar]

Hi,

Can anyonehelp with this macro please,

It is supposedto open each excel file in a folder copy specific cells onto one row of theworkbook move onto the next file.


Dim wb As Workbook,ws As Worksheet


Set fso =CreateObject("Scripting.FileSystemObject")

Set fldr =fso.GetFolder("P:\Devonport\Intec\Design Services\BSG\IH Info\TestCables")

y =ThisWorkbook.Sheets("Cable_check_list").Cells(Rows.Count,1).End(x1Up).Row + 1

For Each wbFile Infldr.Files
y = ThisWorkbook.Sheets("Cable checklist").Cells(Rows.Count, 1).End(x1Up).Row + 1

Iffso.GetExtensionName(wbFile.Name) = "xls" Then

Set ws =Workbooks.Open(wbFile.Path)

ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 1) = ws.Cells(60, 20) 'drawing No.
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 2) = ws.Cells(60, 33) 'sheet no.
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 3) = ws.Cells(53, 20) 'Title
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 4) = ws.Cells(3, 37) 'ref
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 5) = ws.Cells(3, 43) 'cable No.
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 6) = ws.Cells(11, 3) 'Location A
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 7) = ws.Cells(11, 25) 'Location B
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 8) = ws.Cells(7, 3) 'Cable Type
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 9) = ws.Cells(7, 43) 'separation
ThisWorkbook.Sheets("Cable DataSheet").Cells(y, 10) = ws.Cells(7, 37) 'Measured Length


y = y + 1

wb.Close

End If

Next wbFile

End Sub
>

 

[mumps]

For clarification:
What is the name of the sheet that contains the data you want to copy in each workbook?
What is the name of the sheet where you want the data pasted?

 

[Haggar]

the active workbook is named Cable check list and the sheet have the same name is that my error

 

[mumps]

I need the specific sheet names in the source workbooks and the destination workbook, for example: "Sheet1", "Data Sheet". Are the source files you want to open the only files in that folder?

 

[Fluff]

How about

Dim wb As Workbook, ws As Worksheet


Set FSO = CreateObject("Scripting.FileSystemObject")

Set Fldr = FSO.getFolder("P:\Devonport\Intec\Design Services\BSG\IH Info\TestCables")

For Each wbfile In Fldr.files
   y = ThisWorkbook.Sheets("[COLOR=#ff0000]Cable DataSheet[/COLOR]").Cells(Rows.Count, 1).End(xlUp).Row + 1
   
   If FSO.GetExtensionName(wbfile.Name) = "xls" Then
   
      Set wb = Workbooks.Open(wbfile)
      Set ws = wb.Sheets("[COLOR=#ff0000]Cable DataSheet[/COLOR]")
      With ThisWorkbook.Sheets("[COLOR=#ff0000]Cable DataSheet[/COLOR]")
         .Cells(y, 1) = ws.Cells(60, 20) 'drawing No.
         .Cells(y, 2) = ws.Cells(60, 33) 'sheet no.
         .Cells(y, 3) = ws.Cells(53, 20) 'Title
         .Cells(y, 4) = ws.Cells(3, 37) 'ref
         .Cells(y, 5) = ws.Cells(3, 43) 'cable No.
         .Cells(y, 6) = ws.Cells(11, 3) 'Location A
         .Cells(y, 7) = ws.Cells(11, 25) 'Location B
         .Cells(y, 8) = ws.Cells(7, 3) 'Cable Type
         .Cells(y, 9) = ws.Cells(7, 43) 'separation
         .Cells(y, 10) = ws.Cells(7, 37) 'Measured Length
      End With
      wb.Close
      Set ws = Nothing
   End If

Next wbfile

Change sheet names in red if needed

 

[Haggar]

Wow! superb thank you very much

 

[Fluff]

You're welcome & thanks for the feedback