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.

Hello Old Friend,

I thought that you had given up! I had a picture of you way out in the wilderness, in a remote outback hotel, tumbleweeds blowing around, sitting at the bar, four empties in front of you with a top-up on the way, head in hands saying "Why me?" !!

Let me know how it goes.

Cheerio,
vcoolio.

Hello there again,

Glad to know that its working now. Its still working nicely on this end (both codes!). As for the high-lighting, if you are referring to the blue coloured high-lighting once copying/pasting is done, just click away. This is Excel's way of telling you that the task is done. Its part and parcel of the whole process.
As for the settings, click on the File tab in your work sheet (top left) then select Options. Next, select Trust Centre and then click on the Trust Centre settings button. On the left hand side of the dialogue box that pops up, you will see a list of categories. Go through each one, but mainly:-

- Macro Settings
- File Block Settings
- Protected View
- External Content
- Trusted Documents

and check that all machines have identical settings. All default settings are and should be identical.

Good luck old fella.

Cheerio,
vcoolio.

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.