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

Haggar

New Member
Joined
Feb 9, 2017
Messages
9
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
>
 

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,144
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

New Member
Joined
Feb 9, 2017
Messages
9
the active workbook is named Cable check list and the sheet have the same name is that my error
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
10,144
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

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,113
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

How about
Code:
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
53,113
Office Version
  1. 365
Platform
  1. Windows
You're welcome & thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,122,911
Messages
5,598,819
Members
414,260
Latest member
joishe

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
Top