Automatically copy only filled rows from certain sheets to one data sheet

[Summer2021]

Greetings everyone,

Hope you can share your opinions on this specific matter (I have looked for couple hours and haven't found this specific topic in the discussions).

I have created a task tracker for my team of 10 people. There are 10 sheets for everyone of us to fill they weekly tasks and one sheet with main data table where all rows with filled tasks should appear (also there are more sheets with other information). I tried power query, and it worked perfectly, but then I realised I had to make this file shared for everyone to edit it and It's not allowed when workbook contains tables (Office 2010)... So now I am trying to come up with vba code that would (automatically or not) copy only filled rows from everyones sheet (for example, everyone would have 10 blank rows to fill, From B4-K4 to B13-K13 (without headers)) and copy them (when they are filled) to the main table which starts from F14-O14.

Thank you very much in advance.

Have a good evening!

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Automatically copy only filled rows from certain sheets to one data sheet
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[Summer2021]

I apologize for cross-posting in two forums. The aim was just to find the answer in different platforms, different opinions. Sorry for breaking the rule No 13. This this the link to the same post:

Automatically copy only filled rows from certain sheets to one data sheet

 

[fadee2]

hi summer2021,

I would suggest uploading a desensitized (if necessary) sample worksheet on dropbox or googledrive and pasting the link the thread, that would make it easier for everyone trying to help to better understand and suggest solutions accordingly, rather then interpreting the query and making assumptions.

 

[Summer2021]

Hi Fadee2,

Thank you for your message.

Please find below the dropbox link with a simplified copy of my workbook:

Excel

Shared with Dropbox

www.dropbox.com

Thank you in advance.

 

[fadee2]

Assuming you have names of your teammembers in a sheet2 formatted as table (team)

Try following code.

Sub Summer2021()
Dim ws As Worksheet
Dim teammembers() As Variant
Dim rngorig As Range


teammembers = Sheets("sheet2").ListObjects("team").DataBodyRange.Value
For Each member In teammembers()
    
    Set rngorig = Sheets(member).Range("b4:j6")

        For Each Row In rngorig.Rows
            lr = Sheets("Master").Cells(Rows.Count, 6).End(xlUp).Row
            
            If Application.CountA(ActiveCell.EntireRow) <> 0 Then
                Row.Copy
                Sheets("master").Cells(lr + 1, 6).PasteSpecial Paste:=xlPasteValues
            End If
        Next

Next member


Set rngorig = Nothing

End Sub

hth....

 

[Summer2021]

Dear Fadee2,

Thank you for your message.

Since I am new to vba, please clarify did I understand you correctly: I created a new sheet (sheet2) where I made the table with 3 team members (as you specified in the egz.), then entered the vba code, but the command doesn't work. I would greatly appreciate your oppinion.

Have a good evening!

 

[fadee2]

Yes thats exactly what is needed to be done. Secondly, did you rename the table as team? Plus the name of the sheet on which this table resides is sheet 2.

but the command doesn't work

What is the resulting error???

 

[Summer2021]

Error - Subscript out of range.

 

[fadee2]

Since you have already created a new worksheet with your team member names residing in an excel table named as team. try the following code:

Sub Summer2021()
Dim teammembers() As Variant
Dim rngorig As Range
Dim rngdest As Range

teammembers = Range("team").ListObject.DataBodyRange.Value

For Each member In teammembers()
    
    Set rngorig = Sheets(member).Range("b4:j6")
    Set rngdest = Sheets("master").Range("f" & lr + 1)
    
        For Each Row In rngorig.Rows
            lr = Sheets("Master").Cells(Rows.Count, 6).End(xlUp).Row
            
            If Application.CountA(Row) <> 0 Then
                Row.Copy
                Sheets("master").Cells(lr + 1, 6).PasteSpecial Paste:=xlPasteValues
            End If
        Next

Next member

lr = ""
Set rngorig = Nothing
Set rngdest = Nothing

End Sub

If error persists, try checking the code, step by step, using F8 key to find the piece of code generating error, and post that piece of code in the thread.
Sample file is available here, containing the code and all relevant changes.


hope this helps.