I need a macro that can extract data

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.

Vcoolio, Thank you very much for your assistance. You've been very helpful. Thanks again

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

Hello Excelmwangi,

I have gone right through your work book and all seems in order. I found four entries with the asterisk which have data in the row beside it and they all transfer nicely once your button is pressed. I tried additional random entries and they all transferred to the Master sheet nicely.
There are a lot of rows marked with the asterisk but no data in them so these rows will not be transferred over.

The other thing to remember, and I don't think that I told you previously, is that the code does require an entry in Column C (Vicariate) for it to execute. This column is the code's reference and it "homes in", so to speak, on the cell reference in Column C from the bottom of the sheet (by rows) and from the far, far right of the sheet (by columns). A bit like cross hairs on a scope. These two lines of code are the ones involved with the "cross hair' scenario:-

lCol = Cells(5, Columns.Count).End(xlToLeft).Column
Range(Cells(cell.Row, "C"), Cells(cell.Row, lCol)).Resize(, 20).Copy

and when one cell is found, the code moves on to the next cell referenced by:-

Next cell

and then, when one sheet is searched:-

NextSheet;
Next ws

in the code.

Just to be sure, re-assign the macro to the button:-
- Right click on the button.
- Select Assign Macro.
- In the Assign Macro box which appears, click on CopyData.
- Click OK.

Let me know how it goes.

Cheers,
vcoolio.

Hello again Old Friend,

Everything works fine at this end still, especially in your actual work book.

Lets go down another road. Try this code instead:-

Sub CopyItAgain()
Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim DestSht As Worksheet
    Dim DestRow As Long
    Dim LastRow As Long
    Set DestSht = Worksheets("Master")
    DestRow = DestSht.Range("B" & Rows.Count).End(xlUp).Row + 1

    For Each ws In Worksheets
        A = ws.Name
Select Case ws.Name
    Case "PSM", "CCHD", "DOI", "FG", "FSW", "GS", "MM", "SMD", "PM":
    With ws
    .UsedRange.AutoFilter Field:=1, Criteria1:="*"
    .UsedRange.Offset(4, 2).Copy
     DestSht.Cells(DestRow, 2).PasteSpecial xlPasteValues
    .UsedRange.AutoFilter
End With
    
    DestRow = DestSht.Range("B" & Rows.Count).End(xlUp).Row + 1

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

End Sub

This code actually uses the AutoFilter function and won't need a cell to home in on so this code will copy whatever you have on a row marked with the asterisk (even if the Vicariate in Column C is not filled in).

Enter this code in a separate module and just run it from Visual Basic without a button. If it works OK from there, then delete the old button and start afresh by creating a new button and assign the new macro to it. It would probably be best to do this in a copy of your work book instead of your actual work book.

Let me know how it pans out.

Cheers,
vcoolio.