Applying a loop to part of a macro

[TheMart007]

Hi All,

Very new to macro etc and have mashed together bits and pieces to try and create the code that i need. I am nearly there but just need to tell it to repeat as needed. Here is the code I have so far:

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 strSrcCell5 As String
Public strSrcCell6 As String
Public strSrcCell7 As String
Public strSrcCell8 As String
Public strSrcCell9 As String
Public strSrcCell10 As String
Public intStartCell As Integer
Sub DataCopy()
strSourceFldr = "D:\savedfrommain\My Documents\Sales\Quote Materials\Quotes Sent"
strSheetName = "Sheet1"
strSrcCell1 = "B7"
strSrcCell2 = "B8"
strSrcCell3 = "B9"
strSrcCell4 = "B10"
strSrcCell5 = "A13"
strSrcCell6 = "B13"
strSrcCell7 = "C13"
strSrcCell8 = "D13"
strSrcCell9 = "E13"
strSrcCell10 = "F13"
intStartCell = 2
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set objFolder = objFSO.GetFolder(strSourceFldr)
For Each EachFile In objFolder.Files
If LCase(objFSO.GetExtensionName(EachFile)) = "xls" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFSO.GetFolder(strSourceFldr)
End Sub
Sub ProcessFile(ByRef ThisFile As Object)
Dim Cell1, Cell2, Cell3, Cell4, Cell5, Cell6, Cell7, Cell8, Cell9, Cell10
Set objFile = objFSO.GetFile(ThisFile)
Workbooks.Open ThisFile
Cell1 = Range(strSrcCell1).Value
Cell2 = Range(strSrcCell2).Value
Cell3 = Range(strSrcCell3).Value
Cell4 = Range(strSrcCell4).Value
Cell5 = Range(strSrcCell5).Value
Cell6 = Range(strSrcCell6).Value
Cell7 = Range(strSrcCell7).Value
Cell8 = Range(strSrcCell8).Value
Cell9 = Range(strSrcCell9).Value
Cell10 = Range(strSrcCell10).Value
ActiveWorkbook.Close
Worksheets(1).Cells(intStartCell, 1) = ThisFile.Name
Worksheets(1).Cells(intStartCell, 2) = Cell1
Worksheets(1).Cells(intStartCell, 3) = Cell2
Worksheets(1).Cells(intStartCell, 4) = Cell3
Worksheets(1).Cells(intStartCell, 5) = Cell4
Worksheets(1).Cells(intStartCell, 6) = Cell5
Worksheets(1).Cells(intStartCell, 7) = Cell6
Worksheets(1).Cells(intStartCell, 8) = Cell7
Worksheets(1).Cells(intStartCell, 9) = Cell8
Worksheets(1).Cells(intStartCell, 10) = Cell9
Worksheets(1).Cells(intStartCell, 11) = Cell10
Worksheets(1).Cells(intStartCell, 12) = ThisFile.Path
intStartCell = intStartCell + 1

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)) = "xls" Then
ProcessFile EachFile
End If
Next
ProcessSubFolder objFolder
Next
End Sub


In the DataCopy section, I need it to copy the cells listed and then check "B14" to see if there is an entry in this cell and then perform the copy from A14-F14 if there is an entry. I need to to continue down until it reaches 2 empty rows. Obviously this needs to be done for all workbooks in the folder but I think that is already set.

Any help gratefully received!!

TheMart