Page 2 of 2 FirstFirst 12
Results 16 to 21 of 21
  1. #16
    5 Star Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,089
    Thanks
    39
    Thanked 190 Times in 177 Posts
    Very simple resolution. In the code for the new form, change the 7 to a 9:
    emptyRow = .Cells(1, 9).End(xlDown).Row + 1

    You must select a column that counts down from row 2. Column 9-23 in the data sheet has a value in row 2 so changing the column to any of those will resolve your issue. If you look on the other data sheet, I chose 7 because it has a value in row 2 where the others are merged. If you were not using merged cells in the header row, any header column would be acceptable as long as it has a header value.

    Maud

  2. #17
    New Lounger
    Join Date
    Jun 2014
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    Utilities Route working.xlsm

    OK I am back with another issue and hopefully you can help. I have recently lost the ability to use Outlook to email the report on a daily basis. SO the only way I can efficiently do this is come up with a script that when they are finish with the route it will take all of the data on sheets 2, 3, and 4 and insert it in another workbook. It would be nice if when the script pastes the dat it uses something like a lastcell or some other way of finding the first blank row so I can keep compiling the data in one sheet. I was wondering if you might lead me in the right direction as I have no idea where to even start. I know this is a lot to ask but if you just get me started I may be able to figure out the rest. Attached is what I have so far.

  3. #18
    5 Star Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,089
    Thanks
    39
    Thanked 190 Times in 177 Posts
    Scubajay,

    Here is the code that should do what you want. Clicking on the Transfer button will open the destination workbook and transfer each row from sheets 2 through 4 in the source file to corresponding sheets in the destination file. The newly added rows in the destination file will be appended to any existing rows. Lastly, the macro will save and close the destination file with no user intervention.

    You will need to change Path to the path of your destination file. It does not matter if the destination file is open or closed when the routine is initiated but either way, it will close and save upon completion. I have left some test data in the attached sample to play with

    HTH,
    Maud

    Code:
    Sub Transfer()
    On Error Resume Next
    '---------------------------------------------
    'DECLARE OBJECTS/VARIABLES
        Dim Targetbook As Workbook
        Dim Sourcebook As Workbook
        Dim Path
    '---------------------------------------------
    'OPEN TARGET WORKBOOK AND SET VARIABLE TO WORKBOOKS
        Path = "C:\Users\Maudibe\Desktop\"
        Workbooks.Open Filename:=Path & "Utilities DB.xlsx"
        Set Targetbook = Workbooks("Utilities DB.xlsx")
        Set Sourcebook = Workbooks("Utilities Route working.xlsm")
    '---------------------------------------------
    'CYCLE THROUG SHEETS IN EACH WORKBOOK AND COPY DATA
    For I = 2 To 4
        LastRow = Sourcebook.Worksheets(I).Cells(Rows.Count, 2).End(xlUp).Row
        EndRow = Targetbook.Worksheets(I - 1).Cells(Rows.Count, 2).End(xlUp).Row
        LastRow = IIf(LastRow < 2, 2, LastRow)
        EndRow = IIf(EndRow < 2, 2, EndRow)
        Select Case I
            Case 2: col = 24
            Case 3: col = 27
            Case 4: col = 4
        End Select
        For J = 3 To LastRow
            For K = 1 To col
                Targetbook.Worksheets(I - 1).Cells(EndRow + 1, K) = Sourcebook.Worksheets(I).Cells(J, K)
            Next K
            EndRow = EndRow + 1
        Next J
    Next I
    '--------------------------------------------
    'SAVE AND CLOSE TARGET WORKBOOK
    Application.DisplayAlerts = False
    Targetbook.Close savechanges:=True
    Application.DisplayAlerts = True
    End Sub
    Attached Files Attached Files
    Last edited by Maudibe; 2014-07-15 at 22:25.

  4. #19
    New Lounger
    Join Date
    Jun 2014
    Posts
    9
    Thanks
    0
    Thanked 0 Times in 0 Posts
    WOW! once again you have amazed me!

    I will buy you a beer if you can tell me how to make it check the target for duplicates before it inserts the data. Would I use a IF statement or is there a better way?

  5. #20
    5 Star Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    1,089
    Thanks
    39
    Thanked 190 Times in 177 Posts
    Scubajay,

    I think this should do the trick.....Heineken!

    Code:
    Sub Transfer()
    On Error Resume Next
    '---------------------------------------------
    'DECLARE OBJECTS/VARIABLES
        Dim Targetbook As Workbook
        Dim Sourcebook As Workbook
        Dim Path
    '---------------------------------------------
    'OPEN TARGET WORKBOOK AND SET VARIABLE TO WORKBOOKS
        Path = "C:\Users\Maudibe\Desktop\"
        Workbooks.Open Filename:=Path & "Utilities DB.xlsx"
        Set Targetbook = Workbooks("Utilities DB.xlsx")
        Set Sourcebook = Workbooks("Utilities Route working.xlsm")
    '---------------------------------------------
    'CYCLE THROUG SHEETS IN EACH WORKBOOK AND COPY DATA
    For I = 2 To 4
        LastRow = Sourcebook.Worksheets(I).Cells(Rows.Count, 2).End(xlUp).Row
        EndRow = Targetbook.Worksheets(I - 1).Cells(Rows.Count, 2).End(xlUp).Row
        LastRow = IIf(LastRow < 2, 2, LastRow)
        EndRow = IIf(EndRow < 2, 2, EndRow)
    '---------------------------------------------
    'DETERMINE NUMBER OF COLUMNS ON SHEET
        Select Case I
            Case 2: col = 24
            Case 3: col = 27
            Case 4: col = 4
        End Select
    '---------------------------------------------
    'CYCLE THROUGH ROWS ON SHEETS
        For J = 3 To LastRow
        '---------------------------------------------
        'CHECK FOR DUPLICATES
            For M = 3 To EndRow
                If Sourcebook.Worksheets(I).Cells(J, 2) = Targetbook.Worksheets(I - 1).Cells(M, 2) Then GoTo NextAsset
            Next M
        '---------------------------------------------
        'COPY ASSET TO TARGET SHEET
            For K = 1 To col
                Targetbook.Worksheets(I - 1).Cells(EndRow + 1, K) = Sourcebook.Worksheets(I).Cells(J, K)
            Next K
            EndRow = EndRow + 1
    NextAsset:
        Next J
    Next I
    '--------------------------------------------
    'SAVE AND CLOSE TARGET WORKBOOK
    Application.DisplayAlerts = False
    Targetbook.Close savechanges:=True
    Application.DisplayAlerts = True
    End Sub

  6. #21
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    5,960
    Thanks
    193
    Thanked 730 Times in 666 Posts
    Maud,

    Just a thought.

    How about replacing this:
    Code:
        'CHECK FOR DUPLICATES
            For M = 3 To EndRow
                If Sourcebook.Worksheets(I).Cells(J, 2) = Targetbook.Worksheets(I - 1).Cells(M, 2) Then GoTo NextAsset
            Next M
        '---------------------------------------------
        'COPY ASSET TO TARGET SHEET
            For K = 1 To col
                Targetbook.Worksheets(I - 1).Cells(EndRow + 1, K) = Sourcebook.Worksheets(I).Cells(J, K)
            Next K
            EndRow = EndRow + 1
    NextAsset:
    With this:
    Code:
       Dim rngResults As Range
    
       Set rngResults = Targetbook.Worksheets(I - 1).Range(Cells(3, 13), Cells(lEndRow, 13)).Find(Sourcebook.Worksheets(I).Cells(J, 2), LookIn:=xlValues)
       
       If rngResults Is Nothing Then  '*** NOT Found ***
        'COPY ASSET TO TARGET SHEET
            For K = 1 To col
                Targetbook.Worksheets(I - 1).Cells(EndRow + 1, K) = Sourcebook.Worksheets(I).Cells(J, K)
            Next K
            EndRow = EndRow + 1
       End If
    I think this code has 2 advantages:
    1. The Find should be more efficient that the loop.
    2. It gets rid of the GoTo.

    Note: I tested the concept code but I have NOT tested the integration into your code!

    HTH

    FYI: Here's my test file: TestFindCode.xlsm
    May the Forces of good computing be with you!

    RG

    VBA Rules!

    My Systems: Desktop Specs
    Laptop Specs


  7. The Following User Says Thank You to RetiredGeek For This Useful Post:

    Maudibe (2014-07-18)

Page 2 of 2 FirstFirst 12

Posting Permissions

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