Consulting

Results 1 to 11 of 11

Thread: Solved: Help with a loop

  1. #1
    VBAX Regular
    Joined
    May 2004
    Location
    Louisiana, USA
    Posts
    33
    Location

    Question Solved: Help with a loop

    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

  2. #2
    VBAX Contributor Richie(UK)'s Avatar
    Joined
    May 2004
    Location
    UK
    Posts
    188
    Location
    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.
    [vba]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" & .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[/vba]HTH

  3. #3
    VBAX Regular
    Joined
    May 2004
    Location
    Louisiana, USA
    Posts
    33
    Location

    Thumbs up

    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

  4. #4
    VBAX Contributor Richie(UK)'s Avatar
    Joined
    May 2004
    Location
    UK
    Posts
    188
    Location
    Hi ET,

    OK, something like this?[vba]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" & .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[/vba]

  5. #5
    VBAX Regular
    Joined
    May 2004
    Location
    Louisiana, USA
    Posts
    33
    Location
    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

  6. #6
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,897
    Location
    Hi ET,

    Try something like this..

    [vba]
    rngCopy.Copy Destination:=wbkContract.Worksheets("Sheet1").Range("A65536").End(xlUp).Off set(1)
    [/vba]

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

  7. #7
    VBAX Regular
    Joined
    May 2004
    Location
    Louisiana, USA
    Posts
    33
    Location
    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

  8. #8
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,897
    Location
    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!

  9. #9
    VBAX Contributor Richie(UK)'s Avatar
    Joined
    May 2004
    Location
    UK
    Posts
    188
    Location
    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!

  10. #10
    Site Admin
    Urban Myth
    VBAX Guru
    Joined
    May 2004
    Location
    Oregon, United States
    Posts
    4,897
    Location
    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)

  11. #11
    VBAX Regular
    Joined
    May 2004
    Location
    Louisiana, USA
    Posts
    33
    Location
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •