1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  3. When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Copying particular cells from one workbook to another based on the text in another cell.

Discussion in 'VBA Macros' started by Brooksy1, Jan 6, 2017.

  1. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Hello all,

    My first post on here so please let me know if i need to do anything more in this post.

    I have a workbook that holds some data and a dropdown box. What i would like to do is get some VBA code that would copy and past particular active cells to another workbook on a shared drive. However i would like to alter which workbook it copies the cells to depending on which text is selected in the drop down box. I have attached an example of the workbook to help.

    The cells i would want to copy are A7:A27, C7:C27 but only if they have text in them.

    The drop down box is in cell B2 on the attached example and the two options are "Book 1" or "Book 2"

    I would also be running this VBA multiple times a day for different data (as the sending book is a template that will be clean of data each time it is opened) so would need the code to paste below any rows that are already in use on the book where the data will be posted.

    I hope this makes sense.

    I have searched this forum and others and although there is a lot of posts about this subject across the net they do not refer to one cell with multiple options and tend to copy entire rows which is not what i would like to happen if possible.

    Many thanks for any help in advance.

    Attached Files:

  2. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Hi and welcome to the forum :)

    Please try the following (you must have all 3 workbooks open before running the code and the other 2 files must be named exactly as in cell "B2"):
    Code (vb):
    Sub CopyPaste()

        Dim lrow, lrow1 As Integer
     
        lrow = Sheets("Calculations").Columns("A").Cells(Rows.Count).End(xlUp).Row
        lrow1 = Workbooks(Range("B2").Value).Sheets(1).Columns("A").Cells(Rows.Count).End(xlUp).Row + 1

        Sheets("Calculations").Range("A7:A" & lrow & "," & "C7:C" & lrow).Copy Workbooks(Range("B2").Value).Sheets(1).Range("A" & lrow1)

    End Sub
    Code should be placed in the sending/source workbook... Please refer to the attached files

    Hope this helps

    Attached Files:

    Brooksy1 likes this.
  3. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    PCosta87

    Thank you that works beautifully!

    The only one thing i would like is for it to work without the book open as in the macro will open the correct book paste the appropriate data and close the receiving book again. Is this something that is possible?

    Apologies i should have probably said this in the original post.
  4. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    No problem :)

    Replace with
    Code (vb):
    Sub CopyPaste()

        Dim lrow, lrow1 As Integer
        Dim Path, Dest, Source As String
       
        Source = ActiveWorkbook.Name
        lrow = Workbooks(Source).Sheets("Calculations").Columns("A").Cells(Rows.Count).End(xlUp).Row
        Dest = Workbooks(Source).Sheets("Calculations").Range("B2").Value
        Path = "D:\" & Dest & ".xlsx"
       
        Workbooks.Open Path
            lrow1 = Workbooks(Dest).Sheets(1).Columns("A").Cells(Rows.Count).End(xlUp).Row + 1
            Workbooks(Source).Sheets("Calculations").Range("A7:A" & lrow & "," & "C7:C" & lrow).Copy Workbooks(Dest).Sheets(1).Range("A" & lrow1)
        Workbooks(Dest).Close savechanges:=True

    End Sub
    Note that I used "D:\..." you need to replace this path with the one where you have your 2 files. Also, change the ".xlsx" if your files have a different extension.

    Hope this helps
    Brooksy1 likes this.
  5. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Thanks again PCosta87

    I have tried to make it work but i keep getting a 'subscript out of range' error. The following line is highlighted in the debugger.

    lrow1 = Workbooks(Dest).Sheets(1).Columns("A").Cells(Rows.Count).End(xlUp).Row + 1

    This happens regardless of which sheet i select in the drop down. The appropriate workbook opens but nothing is copied before this error is shown. So close!
  6. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Can you please upload your file with the code in place so I can take a look... it seems to be working ok on my end.

    Thank you
  7. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Thanks again for your help.

    The files are attached, Hopefully its not something i have done to break it!

    Attached Files:

  8. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Weird... I changed "C:" to "D:" and recreated the exact same path and it worked on first try.
    It must be something else... try leaving only the "example" file open before clicking the button. If the problem persists try changing the path to something shorter like "C:\" and see if it works.
    Brooksy1 likes this.
  9. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Unfortunately still the same issue. Thank you so much for the help!

    I can see it is nearly there as it does everything up to that point. I will continue to play around with some different locations and the code and see if i can get it to finalize.
  10. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    It would be great if I could replicate the error... :(
    If you can't figure it out in the weekend I will get back to this on Monday and hopefully we can sort something out.

    Have a nice weekend :)
  11. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Good morning PCosta,

    How was your weekend?

    I have had a play around (changed sheet names, changed workbook names, moved the code into new workbooks, placed the files so that the file path was shorter etc) but still hit the same issue as described above.

    Let me know if you need anything more from me to help, maybe some pics of the issue etc?

    Many thanks for all your help again.
  12. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Hi,

    I had a great weekend, thank you... how was yours?

    About the problem, let's try forcing the code to resume after the error (this shouldn't solve the problem but may give us some more info about what is causing it):
    Code (vb):
    Sub CopyPaste()

        On Error Resume Next

        Dim lrow, lrow1 As Integer
        Dim Path, Dest, Source As String
     
        Source = ActiveWorkbook.Name
        lrow = Workbooks(Source).Sheets("Calculations").Columns("A").Cells(Rows.Count).End(xlUp).Row
        Dest = Workbooks(Source).Sheets("Calculations").Range("B2").Value
        Path = "C:\Users\Thomas.Brooks\Desktop\Test Environment\Ideas for macro to copy and past data\OPtions\" & Dest & ".xlsx"
     
        Workbooks.Open Path
            lrow1 = Workbooks(Dest).Sheets(1).Columns("A").Cells(Rows.Count).End(xlUp).Row + 1
            Workbooks(Source).Sheets("Calculations").Range("A7:A" & lrow & "," & "C7:C" & lrow).Copy Workbooks(Dest).Sheets(1).Range("A" & lrow1)
        Workbooks(Dest).Close savechanges:=True

    End Sub
    Let me know what happens, thanks
  13. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Morning.

    Mine was great, still recovering but that's always the sign of a good one.

    I tried the new code and it stops the error from coming up. The appropriate sheets opens but nothing is copied onto it and it stays open. No error of any description is shown.

    Is it about now that you are regretting responding to this one :DD
  14. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Nah :)

    It shouldn't throw any error since we forced it to resume... my ideia was to see if it could copy the data. The thing is, it should not be stooping where it is because it clearly was able to follow the path and open the file.

    step 2 :): If you open Book 1 or Book 2 manually, does excel prompt you to enable editing? if so allow it and save the changes (repeat for the other file)

    Then try the macro again and let me know the result

    Thanks
  15. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    So for book 1 it didn't ask to enable editing but for book 2 it did. I saved book 2 and ran the macro for both sheets again but still with the same issue that nothing is pasted.

    I know i keep saying it but thanks for the help with this :)
  16. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Don't worry about it :)
    Let's try it once with all 3 files open.
    What happens then?
  17. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    With all three open the same thing happens it brings the sheet that it is trying to copy to to the front but nothing is pasted.
  18. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    The only thing I can think of is that for some reason your excel is opening the files in different instances instead of the same.

    Open a new excel file and then try opening all 3 files through the File>Open option and then run the code.

    On a side note, what is your version of Excel (Office)?
  19. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    unfortunately still the same issue when using the File>Open option.

    I am using office 2010.
  20. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Well, last try :(

    Try replacing with the following:
    Code (vb):
    Sub CopyPaste()

        Dim lrow, lrow1 As Integer
        Dim Path, Dest, Source As String

        Source = ActiveWorkbook.Name
        lrow = Workbooks(Source).Sheets("Calculations").Columns("A").Cells(Rows.Count).End(xlUp).Row
        Dest = Workbooks(Source).Sheets("Calculations").Range("B2").Value
        Path = "C:\Users\Thomas.Brooks\Desktop\Test Environment\Ideas for macro to copy and past data\OPtions\" & Dest & ".xlsx"

        Workbooks.Open Path
            lrow1 = ActiveWorkbook.Sheets("A").Columns("A").Cells(Rows.Count).End(xlUp).Row + 1
            Workbooks(Source).Sheets("Calculations").Range("A7:A" & lrow & "," & "C7:C" & lrow).Copy ActiveWorkbook.Sheets("A").Range("A" & lrow1)
        Workbooks(Dest).Close savechanges:=True

    End Sub
    and replace previous book 1 and book 2 with the files attached

    See if it works now

    Attached Files:

    Last edited: Jan 9, 2017
  21. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    Ok, so you have worked your magic on the copying and pasting :). When i run the new code it opens the correct workbook and pastes everything it should. I then get a 'subscript out of range' error with the following code showing up in the debugger

    Workbooks(Dest).Close savechanges:=True

    The workbook stays open.
  22. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    Great :)
    Now I see where the problem was... replace:
    Code (vb):
    Workbooks(Dest).Close savechanges:=True
    with
    Code (vb):
    ActiveWorkbook.Close savechanges:=True
    and you should be good to go.
    Brooksy1 likes this.
  23. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    It is still unclear to me why it breaks at "Workbooks(Dest)", even more so since it was able to use that variable in the path, but oh well... just glad it worked out in the end

    I'm sorry it took so long to figure out :)
    Brooksy1 likes this.
  24. Brooksy1

    Brooksy1 New Member

    Messages:
    14
    You sir have skills!! I could kiss you (now imagining some big hairy bloke that really hasn't appreciated that comment haha).

    Thank you so much for all of your help, it really is appreciated.
  25. PCosta87

    PCosta87 Well-Known Member

    Messages:
    658
    You are welcome ;)
    Brooksy1 likes this.

Share This Page