Help with a loop

[ETracker]

Hi
I have been thinking about this one for a while. I would like for someone to help me with the code that will loop through the data and copy it to as many workbooks that is listed or used for that day.

Let me explain this a little bit better: I have a workbook set-up for each contract that we will be charging time to located on the C: drive in a folder named Contracts. I am trying to maintain a data file for each contract and get it updated everyday with new data from the day before.

I am manual sorting the data and manual copying the data to each workbook at this time, I would like to be able to do this with VBA.

I need to sort by column "D", The Contract Column and then have it find the right folder on the C: drive in a folder named Contracts and copy it in that file below the data that is already in this file.

I think I will need to loop through all of the contracts in this column to ensure I have all of the data copied to the correct folder. I will be deleting the rows with a "0" in this column and only be coping the rows with contract numbers.

I will also need a way to add a contract to the C: drive if the vba code finds a contract and there is no folder to copy to data into.

I hope someone can help me with this task

Attached is a copy of the data that I will be copying to the other files.

Thank you very much for any help you can do on this task.

ETracker

[Richie(UK)]

Hi ET,

Welcome to the board.

The following code should help get you started. It sorts the data by reference to column D, uses the Advanced Filter to get a list of the unique contract numbers, and then loops through these unique items opening/creating the workbooks as required. I haven't actually done anything with the opened workbooks yet as I'm not entirely sure what your aim is here - perhaps you could clarify. Alternatively, you may feel able to finish up from here - if so, please let us know.

Sub Test()
    Dim wsData As Worksheet
    Dim rngContracts As Range, rngUnique As Range, rngCell As Range
    Dim strFName As String
    Dim wbkContract As Workbook
    Const strDir As String = "C:\Contracts\"
Set wsData = ThisWorkbook.Worksheets("Time Data")
    'establish a reference to the data sheet
Application.ScreenUpdating = False
With wsData
.Columns("A:H").Sort _
            Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        'sort the data
Set rngContracts = .Range("D1:D" & .Cells(Rows.Count, "D").End(xlUp).Row)
        'the range containing data
        rngContracts.AdvancedFilter _
            Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
        'copy the unique entries to another range (amend "J1" to suit)
        Set rngUnique = .Range("J2:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
        'the range of unique contract numbers (start from J2 to exclude header)
For Each rngCell In rngUnique
strFName = strDir & rngCell.Value & ".xls"
If FileExists(strFName) Then
                Set wbkContract = Workbooks.Open(Filename:=strFName)
            Else
                Set wbkContract = Workbooks.Add
                wbkContract.SaveAs Filename:=strFName
            End If
            'check if workbook already exists, if not then create it
'do stuff with wbkContract
wbkContract.Close savechanges:=True
            'close the contract workbook (saving changes)
Next rngCell
        'loop through each contract
End With
Application.ScreenUpdating = True
End Sub

Function FileExists(strFullname As String) As Boolean
    FileExists = Dir(strFullname) <> ""
End Function

HTH

[ETracker]

First of all, Thanks Richie for the quick response.

I have inserted your code into the data sheet and it is running great and giving me a unique list of contracts in column "J". You have asked me to clarify what I need to do next.

I think I am wanting to filter the data by each contract listed in column "J" and after it is filtered, copy the filtered data by each contract to each file on the Crive in the contract folder. Please note that the name of the file in the Contract Folder is named as the Contract Number "60963" "60964" and so on. Some of the files will all ready be there due to time already beig charged to them and some will not because this would be the first day time would have been charged to this contract, that is why I need the code to create the file in the contract folder if it does not exists.

I hope this clarifys the task a little bit better.

Again Thanks Richie for you help.

ETracker

[Richie(UK)]

Hi ET,

OK, something like this?

Sub Test()
    Dim wsData As Worksheet
    Dim rngContracts As Range, rngUnique As Range, rngCell As Range, rngCopy As Range
    Dim strFName As String
    Dim wbkContract As Workbook
    Const strDir As String = "C:\Contracts\"
Set wsData = ThisWorkbook.Worksheets("Time Data")
    'establish a reference to the data sheet
Application.ScreenUpdating = False
With wsData
.Columns("A:H").Sort _
            Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        'sort the data
Set rngContracts = .Range("D1:D" & .Cells(Rows.Count, "D").End(xlUp).Row)
        'the range containing data
        rngContracts.AdvancedFilter _
            Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
        'copy the unique entries to another range (amend "J1" to suit)
        Set rngUnique = .Range("J2:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
        'the range of unique contract numbers (start from J2 to exclude header)
For Each rngCell In rngUnique
If rngCell.Value > 0 Then
strFName = strDir & rngCell.Value & ".xls"
                If FileExists(strFName) Then
                    Set wbkContract = Workbooks.Open(Filename:=strFName)
                Else
                    Set wbkContract = Workbooks.Add
                    wbkContract.SaveAs Filename:=strFName
                End If
                'check if workbook already exists, if not then create it
rngContracts.AutoFilter Field:=1, Criteria1:=rngCell.Value
                Set rngCopy = .AutoFilter.Range.Offset(1, -3).Resize _
                    (.AutoFilter.Range.Rows.Count - 1, 8).SpecialCells(xlCellTypeVisible)
                'AutoFilter contract data and resize
rngCopy.Copy Destination:=wbkContract.Worksheets("Sheet1").Range("A2")
                wbkContract.Close savechanges:=True
                'copy data and then close the contract workbook (saving changes)
rngContracts.AutoFilter
End If
Next rngCell
        'loop through each contract
End With
Application.ScreenUpdating = True
End Sub

Function FileExists(strFullname As String) As Boolean
    FileExists = Dir(strFullname) <> ""
End Function

[ETracker]

Hi Richie, Thanks for your response,

This is working great, my only problem is that is is copying the new data over the existing data in the files in the workbook folder that already exist.

I have tried to change this line of code:

rngCopy.Copy Destination:=wbkContract.Worksheets("Sheet1").Range("A2")

to this line of code so it will copy below the existing data:

rngCopy.Copy Destination:=wbkContract.Worksheets("Sheet1").End(xlUp).Offset(1, -1).Row)

But I am getting a Compile Error and Syntax Error. I must have something wrong.

If you can tell me what I need to change to get the data to copy below the existing data, I think this will solve this issue.

Again Thank you for you time, you have done a very good job with this one.

ET

[Zack Barresse]

Hi ET,

Try something like this..

rngCopy.Copy Destination:=wbkContract.Worksheets("Sheet1").Range("A65536").End(xlUp).Offset(1)

..which will put it one row below the last cell with data in it from column A. You can put back the second '-1' in the offset if you want it to paste one column to the right, but it would need to be a column greater than column A, else you'll receive a range error.

[ETracker]

Thanks Firefytr for the quick response, your code correction worked perfectly.

Also I would like to say Thank You to Rickie for his time and effort making this task 100% faster for me. I could not have done this with your help. THANK YOU VERY MUCH!!!!!!

Everyone is doing a great job on this forum, I just really enjoy being here.

This is working just like I wanted it to.
Thanks to everyone,
ET

[Zack Barresse]

I'm glad it worked for you!

Yes, Parry is one of the worlds BEST coder's (imho) and his skill is second to none. We are very fortunate to have him here with us!!

Take care!

[Richie(UK)]

Hi ET,

Glad things worked out for you.

Hi Zack,

Thanks for adding the necessary help at the end. I also think that Parry is a good coder - but it was me that wrote this code!

[Zack Barresse]

Omg! Oh, Richie, my deepest apologies! Yes, Parry is a great coder, but I did mean you! (Wow, I'm such a doof)

RICHIE IS ONE OF THE WORLDS BEST CODERS!!! They both are, no doubt.

(I think I was just reading a post at TOE at the time, I'm not sure, lol)

[ETracker]

Hi everyone,

I wanted to get my two cents in one more time. Yes you are right, Richie you are the one who wrote this code that have made my day.

A Thousand Thank You's to Richie for a job well done, I can't tell you how much help you have been. Thank You again, I really needed your help on this one and you came through with great code that worked great.

Also thank you to firefytr that helped with a small change at the end.
ET