PDA

View Full Version : Solved: Help with a loop



ETracker
08-08-2004, 08:42 PM
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 :dunno :rolleyes: :dunno

Richie(UK)
08-09-2004, 03:55 AM
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 FunctionHTH

ETracker
08-09-2004, 07:32 AM
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 C:Drive 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 :yes

Richie(UK)
08-09-2004, 09:20 AM
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
08-09-2004, 11:32 AM
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
08-09-2004, 11:40 AM
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
08-09-2004, 12:20 PM
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 :dance: :) :)

Zack Barresse
08-09-2004, 01:14 PM
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)
08-10-2004, 01:31 AM
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
08-10-2004, 07:25 AM
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
08-10-2004, 07:48 PM
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 :hi: :hi: :hi: