Hello all,
The issue is the I want to put the condition here in my the code that only copies the desired cells if the sheet is named specifically such as "Jan", if not named as this the worksheet should not be used. The current code I am using was posted on this site in 2009: http://www.mrexcel.com/forum/excel-...ns-copy-specified-cells-all-files-folder.html
My modified code is: Thanks in advance for all the help!
Option Explicit
Public strSourceFldr As String
Public EachFile As Object
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public strSheetName As String
Public strSrcCell1 As String
Public strSrcCell2 As String
Public strSrcCell3 As String
Public strSrcCell4 As String
Public intStartCell As Integer
Sub DataCopy()
strSourceFldr = "C:\Users\user\DB\Monthly Reports\" 'this is the folder path
strSheetName = ("Jan") 'This is the sheet name I want to pull specific data from
strSrcCell1 = "A41" 'Data to copy
strSrcCell2 = "A42"
strSrcCell3 = "A43"
strSrcCell4 = "A44"
intStartCell = 2 'this is the row number to start on
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set objFolder = objFSO.GetFolder(strSourceFldr)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xlsx" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFSO.GetFolder(strSourceFldr)
End Sub
Sub ProcessFile(ByRef ThisFile As Object)
Dim Cell1, Cell2, Cell3, Cell4
Set objFile = objFSO.GetFile(ThisFile)
Workbooks.Open ThisFile
Cell1 = Range(strSrcCell1).Value
Cell2 = Range(strSrcCell2).Value
Cell3 = Range(strSrcCell3).Value
Cell4 = Range(strSrcCell4).Value
ActiveWorkbook.Close
Worksheets(1).Cells(intStartCell, 1) = ThisFile.Name 'intStartCell is the starting cell (#,#) indicate position
Worksheets(1).Cells(intStartCell + 1, 2) = Cell1
Worksheets(1).Cells(intStartCell + 2, 2) = Cell2
Worksheets(1).Cells(intStartCell + 3, 2) = Cell3
Worksheets(1).Cells(intStartCell + 4, 2) = Cell4
'Worksheets(1).Cells(intStartCell, 6) = ThisFile.Path 'this is the path of where the data comes from
intStartCell = intStartCell + 10 'This is the number of rows between inserted data. Must be bigger than reqested range
End Sub
Sub ProcessSubFolder(ByRef ThisFolder As Object)
Dim SubFolder
For Each SubFolder In ThisFolder.SubFolders
Set objFolder = objFSO.GetFolder(SubFolder.Path)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xlsx" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFolder
Next
'Empty Row delete code
Dim i As Long
Sheets("Summary").Select
Range("A1:M500").Select
'We turn off calculation and screenupdating to speed up the macro.
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
'We work backwards because we are deleting rows.
For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
Range("A1").Select
End With
End Sub
The issue is the I want to put the condition here in my the code that only copies the desired cells if the sheet is named specifically such as "Jan", if not named as this the worksheet should not be used. The current code I am using was posted on this site in 2009: http://www.mrexcel.com/forum/excel-...ns-copy-specified-cells-all-files-folder.html
My modified code is: Thanks in advance for all the help!
Option Explicit
Public strSourceFldr As String
Public EachFile As Object
Public objFSO As Object
Public objFolder As Object
Public objFile As Object
Public strSheetName As String
Public strSrcCell1 As String
Public strSrcCell2 As String
Public strSrcCell3 As String
Public strSrcCell4 As String
Public intStartCell As Integer
Sub DataCopy()
strSourceFldr = "C:\Users\user\DB\Monthly Reports\" 'this is the folder path
strSheetName = ("Jan") 'This is the sheet name I want to pull specific data from
strSrcCell1 = "A41" 'Data to copy
strSrcCell2 = "A42"
strSrcCell3 = "A43"
strSrcCell4 = "A44"
intStartCell = 2 'this is the row number to start on
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set objFolder = objFSO.GetFolder(strSourceFldr)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xlsx" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFSO.GetFolder(strSourceFldr)
End Sub
Sub ProcessFile(ByRef ThisFile As Object)
Dim Cell1, Cell2, Cell3, Cell4
Set objFile = objFSO.GetFile(ThisFile)
Workbooks.Open ThisFile
Cell1 = Range(strSrcCell1).Value
Cell2 = Range(strSrcCell2).Value
Cell3 = Range(strSrcCell3).Value
Cell4 = Range(strSrcCell4).Value
ActiveWorkbook.Close
Worksheets(1).Cells(intStartCell, 1) = ThisFile.Name 'intStartCell is the starting cell (#,#) indicate position
Worksheets(1).Cells(intStartCell + 1, 2) = Cell1
Worksheets(1).Cells(intStartCell + 2, 2) = Cell2
Worksheets(1).Cells(intStartCell + 3, 2) = Cell3
Worksheets(1).Cells(intStartCell + 4, 2) = Cell4
'Worksheets(1).Cells(intStartCell, 6) = ThisFile.Path 'this is the path of where the data comes from
intStartCell = intStartCell + 10 'This is the number of rows between inserted data. Must be bigger than reqested range
End Sub
Sub ProcessSubFolder(ByRef ThisFolder As Object)
Dim SubFolder
For Each SubFolder In ThisFolder.SubFolders
Set objFolder = objFSO.GetFolder(SubFolder.Path)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xlsx" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFolder
Next
'Empty Row delete code
Dim i As Long
Sheets("Summary").Select
Range("A1:M500").Select
'We turn off calculation and screenupdating to speed up the macro.
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
'We work backwards because we are deleting rows.
For i = Selection.Rows.Count To 1 Step -1
If WorksheetFunction.CountA(Selection.Rows(i)) = 0 Then
Selection.Rows(i).EntireRow.Delete
End If
Next i
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
Range("A1").Select
End With
End Sub