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
>
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
>