I need a macro that can extract data [Closed]

Report
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015
-
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
-
Hello,

I need help with creating a macro that can automatically copy data from different worksheets and put it into a master worksheet for a report. The problem is that it is on multiple rows on different worksheets and I don't want it to leave empty rows between if I just use the usual worksheet copy way. Please help

4 replies

Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
232
Hello excelmwangi,

The easiest way to do this would be to add a selection criteria to your dataset. So, in the following code, I have added an asterisk "*" in Column A (for each sheet) as the criteria.


Sub CopyData()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "Master" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    
    For Each cell In Range("A2:A" & lRow)
        If cell.Value = "*" Then
            Range(Cells(cell.Row, "A"), Cells(cell.Row, lCol)).Copy
            Sheets("Master").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next cell

NextSheet:
Next ws
Sheets("Master").Range("A1:A" & Rows.Count).ClearContents
Sheets("Master").Select

Application.ScreenUpdating = True
Application.CutCopyMode = False
MsgBox "Data transfer complete", vbExclamation
End Sub


With this code, whichever row you place an asterisk by (ensure this is in Column A), in whichever sheet, the row of data will be copied to the "Master" sheet. The criteria is left behind.

You can have a look at my Test work book here:-

https://www.dropbox.com/s/dfy344w9u1w0509/Excelmwangi.xlsm?dl=0

to see if it works for you.

We can add an additional row of code if you want the transferred data cleared from the worksheets supplying the "Master" sheet. As the code is now, it clears the "Master" sheet prior to the data transfer to prevent duplicates while the data remains in each of the supplying sheets.

Kind regards,
vcoolio.
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Vcoolio, thank you for taking the time. However, when I copied the code and added the criteria, it is still not updating. Am I doing something wrong. Can I upload the document for you to see what's going on? Appreciate the help
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Vcoolio, thank you for taking the time. However, when I copied the code and added the criteria, it is still not updating. Am I doing something wrong. Can I upload the document for you to see what's going on? Appreciate
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Hey, Here is the link to my document. I put the * to the rows I want copied maybe you can help me diagnose and test. Thanks again.

https://www.dropbox.com/s/azbbvcnp4e8flsp/Planning%20Worksheet%20Western%20Vicariate%20-%20Copy.xlsm?dl=0
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
232
Hello excelmwangi,

Having now seen your workbook, its come to light that the problem is being caused by the merged cells. I unmerged all the cells in your work book, including in the "Master" sheet and this slightly amended code now works ok:-

Sub CopyData()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Integer

Application.ScreenUpdating = False

For Each ws In Worksheets
    If ws.Name = "Master" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(5, Columns.Count).End(xlToLeft).Column
    
    For Each cell In Range("A5:A" & lRow)
        If cell.Value = "*" Then
            Range(Cells(cell.Row, "C"), Cells(cell.Row, lCol)).Copy
            Sheets("Master").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next cell

NextSheet:
Next ws

MsgBox "Data transfer complete", vbExclamation
Sheets("Master").Select

Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub


The merged cells can be reformatted without merging, they may just need a little more space. Also, remove the word "criteria" from wherever you have placed it in Column A on each sheet.

I hope this helps,

Kind regards,
vcoolio.
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Thank you so much. My last question would be when I update the master, it duplicates, What code can I add to clear the contents before updating so I don't have duplicate. You have been very helpful thanks again.
Posts
2776
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
July 26, 2021
466
Hi Excelmwangi,

Vcoolio is away for a few days and has asked me to see if you needed any help.

Paste the following code lines after the 6th and before the 8th code line:
Sheets("Master").Select
lRow = Range("B" & Rows.Count).End(xlUp).Row
Range("B5:U" & lRow).ClearContents 


Let us know if you have any questions.

Best regards,
Trowa
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Hi TrowaD,
Thank you for helping me. I copied that code and it doesn't work. I've tried everything but it seems imposible. I've uploaded my document maybe you can see what am doing wrong. I want excel to pick up the rows on the other worksheets with a * as Vcoolio advised and before it copies to master to delete the contents in the master so it doesn't duplicate. Let me know what you think. Thanks again
Here is my drop box link with the document.
https://www.dropbox.com/s/vpk6m8kxc5k6ye7/Test%20Planning%20Worksheet%20Western%20Vicariate%20-%20Copy.xlsm?dl=0
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
232 >
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Hello Excelmwangi,

I'm back. But not for long. I have to leave again tomorrow for another stint in the wilderness.

The following amended code should work for you:-

Sub CopyData()
Dim ws As Worksheet
Dim lRow As Long
Dim lCol As Integer

Application.ScreenUpdating = False

Sheets("Master").Select
Sheets("Master").Range("B5:U" & Rows.Count).ClearContents

For Each ws In Worksheets
    If ws.Name = "Master" Then GoTo NextSheet
    
    ws.Select
    
    lRow = Range("A" & Rows.Count).End(xlUp).Row
    lCol = Cells(5, Columns.Count).End(xlToLeft).Column
    
    For Each cell In Range("A5:A" & lRow)
        If cell.Value = "*" Then
            Range(Cells(cell.Row, "C"), Cells(cell.Row, lCol)).Copy
            Sheets("Master").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
        End If
    Next cell

NextSheet:
Next ws

Sheets("Master").Select

Application.ScreenUpdating = True
Application.CutCopyMode = False

End Sub


You can see it work here in the test work book:-

https://www.dropbox.com/s/wqhg6m4c5icwys1/Excelmwangi%283%29.xlsm?dl=0

This is the latest work book that you uploaded to DropBox.

I hope you don't mind, but I had a good search through your work book and found a number of little things that interrupted the code and adjusted accordingly. It should all be OK now, I think!

BTW, I removed the message box as it became somewhat annoying!
You can click on the blue "Summarise" button to activate the code.

@ Trowa:-

Thanks for looking after the shop while I was away. Much appreciated.

Cheers Gentlemen,
vcoolio.
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015
>
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021

Vcoolio, Thank you very much for your assistance. You've been very helpful. Thanks again
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015
>
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021

By the way, what was distracting my code. I have it running on my larger worksheet but when i add a button for the summary it doesn't pick up the other worksheets, while the one you uploaded works perfect. What was it that you changed so I can change on my final. The macro works but the button skips some rows. Thanks again
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
232
Hello again Excelmwangi,

Just wondering, did you assign the macro to the button? I have a feeling that this could be why its not working for you.

Also, copy and paste the code from my latest test book:-

https://www.dropbox.com/s/ses74bfn90ta6d2/Excelmwangi%284%29.xlsm?dl=0

into your work book. I've made a couple of minor adjustments.

In the "Master" sheet, if the headings are in merged cells (rows 3 & 4), unmerge them and format the headings just in row 3 before applying the adjusted code from above.

Let me know how it goes.

Cheers,
vcoolio.
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

You're an excel sage for sure. The settings worked great. The second code is working but one question is that after entering more info in the worksheets and hitting update, it is not updating some of the new info. Do you think we need to add a clearcontents on the master before updating so we can capture the new information properly. I think that might be the only. Always something with excel....whew. But am enjoying the ride. Thanks again old friend.
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
232 >
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Hello Old Friend,

Light at the end of the tunnel!!

With the second code, try this:-

Remove this line of code from down near the bottom (third last line):-

Sheets("Master").Range("B3:U" & Rows.Count).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12), Header:=xlYes


and add this:-

Sheets("Master").Select
Sheets("Master").Range("B4:U" & Rows.Count).ClearContents


towards the top between:-

 Set DestSht = Worksheets("Master")


and

 DestRow = DestSht.Range("B" & Rows.Count).End(xlUp).Row + 1


You never know......................

Cheers Old Friend,
vcoolio.
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Thank you old friend. I will update you on what happens. Again let me say thank you. Almost there now.
Posts
16
Registration date
Friday February 6, 2015
Status
Member
Last seen
June 5, 2015

Vcoolio,
That one worked perfectly. You're the best. Thank you again.
Now am moving into the protecting my worksheets part of my project....whew.
Posts
1311
Registration date
Thursday July 24, 2014
Status
Moderator
Last seen
July 28, 2021
232
Excellent! I'm glad it has all worked out for you.

As for worksheet protection, keep it simple and use the Excel inbuilt sheet protection function: Review Tab--->Changes Group--->Protect Sheet or Work Book.
It will allow you to also use password protection just in case you need to keep "others" out of your Work Book.

I'll leave it to you to mark this thread as solved. I'm sure that even this will give you some satisfaction!

I'm happy to have been able to assist you.

Don't be afraid to come back.

Cheerio Old Friend.
vcoolio.

Subscribe To Our Newsletter!

The Best of CCM in Your Inbox

Subscribe To Our Newsletter!