Copy / Display row from another sheet

I have a workbook with 10 sheets. 4 Columns in each sheet. "A" is the "QTY" column, which is "0" by default.
When I change the QTY from 0 to 1, the macro copies that row to my "Project" destination sheet.
However, I'm having trouble getting a few features to work.

First, How can I get the Macro to run all the time? or at certain time intervals?
Second, Is there a way to have the macro remove the row from the "project" sheet if the QTY has been changed back to 0? If this is not possible or a really long code; is there a way to have all the rows with >0 in the "QTY" to be simply displayed on my "Project" worksheet and not fully copied? (Probably not).
The reason being, when I run the Macro a second time, It re-copies the rows it already copied (since it's just adding them to the "Project" sheet at the last row).

Here is the code I'm working with, but I had some help with it so I've been having trouble figuring this all out. I'm new to VBA.

Code:

---

Option Explicit


    Sub AddRowContinueOn()
      Dim ws As Worksheet, cws As Worksheet
      Dim cLRow As Integer, sLRow As Integer
   
      Set cws = Worksheets("Complete")
      cLRow = cws.Cells(cws.Rows.Count, "A").End(xlUp).row + 1
 
      Dim i As Integer, val As Integer
      For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Complete" Then
          sLRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).row
          For i = 2 To sLRow
            val = CInt(ws.Cells(i, "A").Value)
            If val <> 0 Then
              cws.Range("A" & cLRow & ":D" & cLRow).Value = ws.Range("A" & i & ":D" & i).Value
              cLRow = cLRow + 1
            End If
          Next
        End If
      Next
 
    End Sub

---

One possibility would be
Read up about what Worksheet_Change does first to see if I understood you right.
Change references (Sheets, Columns) as required.
In the sheet module for every sheet where you need this to happen.

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 Then _
    Cells(Target.Row, 1).EntireRow.Copy Sheets("Project").Cells(Rows.Count, 1).End(xlUp).Offset(1)
End Sub

---

In the Sheet Module for Project Sheet

Code:

---

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 And Cells(Target.Row, 1).Value = 0 Then _
    Cells(Target.Row, 1).EntireRow.Delete Shift:=xlUp
End Sub

---

Thanks jolivanes, it works half way.
I'll clarify a bit more; let's say I have two sheets "Project" and "Items". The Items sheet has 4 columns, only one ever changes, column A, QTY. It is 0 by default. When It is changed from 0, i want to have it copied over to the Project sheet. This works well right now.
When the QTY on the Item sheet is later changed back to 0, I'd like to have that same row now removed from the Project sheet. Right now that doesn't seem to work. It keeps crashing or something.
I'm thinking now, that maybe I'd be better off with two buttons on my project sheet; one that deletes all the row's from that sheet, and one that copies all the rows that aren't 0 from all the other sheets to my Project sheet. Think that would work better? The project sheet is locked and can not be modified.

You say that the project sheet is locked and can not be modified. If you change values, you modify it!
I was under the impression that the values in the second sheet would be changed to 0 (zero)
So there needs to be a common value in that row so that you can search the row to be deleted.
The 2 buttons you mention can of course be done also. It is all up to you. Just need clarification of exactly what is needed.

My Project Sheet:

Attachment 18966
My "Active work sheet"

Attachment 18967

Here is my code:

Code:

---

Private Sub CommandButton1_Click()

ActiveSheet.Range("A2:D300").Select
Selection.Clear
Range("A2").Select


End Sub


Private Sub CommandButton2_Click()


    Dim ws As Worksheet, cws As Worksheet
    Dim cLRow As Integer, sLRow As Integer
   
    Set cws = Worksheets("Project")
    cLRow = cws.Cells(cws.Rows.Count, "A").End(xlUp).Row + 1
   
    Dim i As Integer, val As Integer
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Project" Then
            sLRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            For i = 2 To sLRow
                val = CInt(ws.Cells(i, "A").Value)
                If val <> 0 Then
                    cws.Range("A" & cLRow & ":D" & cLRow).Value = ws.Range("A" & i & ":D" & i).Value
                    cLRow = cLRow + 1
                End If
            Next
        End If
    Next
   
End Sub

---

Everything is working great except because i have a string, "Labour", in cell A145, I get the error msg. I'd like to have the macro copy the range A145:D150, if the cell A146 is > 0 BUT that range needs to be at the end of what was copied from the ws above. Then move on to the next ws.
I'm having trouble clearly expressing what I want to do, but I hope this makes it clear.
Thanks So much for the help.

I can't say that I like pictures. They are notoriously hard to try code on!!!!!!!!
All kidding aside, attach a sanitized workbook with sufficient info to try the code on.
The looping on cells <> 0, does that need to be done from the first row to the row above where you have "Labour"?
It looks like AutoFilter would be the way to go but I need a workbook to work with.

Yeah, I imagine pictures are tough!
The workbook attached is the project sheet and one product sheet. There will be more sheets in the final woorkbook.
The looping should be done from row 2 till the "Labour", yes. Or it could stop above and then check the cell A145. This is because, If any QTY is >0, then the Labour has to be >0.
Thanks so much!

Your CommandButton1 code could be changed to:

Code:

---

Sheets("Project").UsedRange.Offset(1).ClearContents    '<------If you mean to clear the Project sheet

---

I think that the formula in A2 should be without double quotes, like
IF(SUM(A3:A7) =0,0,1)
I assume you want the result to be numbers, not text.






Does this come close to what you had in mind? Try it on a copy of your workbook first.

Code:

---

Sub Maybe()
Dim pjWs As Worksheet, ws As Worksheet, i As Long, lr As Long
Set pjWs = Worksheets("Project")
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Project" Then
            With ws
            lr = .Cells(.Rows.Count, 2).End(xlUp).Row
                For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row - 6
                    If .Cells(i, 1).Value > 0 Then pjWs.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4).Value = .Cells(i, 1).Resize(, 4).Value
                Next i
                If .Cells(lr - 4, 1).Value > 0 Then
                    pjWs.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(6, 4).Value = .Cells(lr - 5, 1).Resize(6, 4).Value
                End If
            End With
        End If
    Next ws
End Sub

---

In your code, you could change the last row line to

Code:

---

ws.Cells(ws.Rows.Count, "A").End(xlUp).Row - 4    '<---- Add the - 4

---

That way you won't have a problem with "Labour"


I used Column B to find the last used row. Just in case someone puts something below the "Labor Cost" cell.
Any particular reason that you use Labour and Labor?

YES YES YES!!! thank you so much!!!! works perfectly!

Labor and Labour is be a typo, lol

Please don't quote entire posts. Quote only what is relevant to your question.

Sorry.

Re: Labor and Labour is be a typo
I thought that you might feel English or North American at different times.

Good that you have it working the way you want it.
Good luck

Quote:

---

Originally Posted by jolivanes

Re: Labor and Labour is be a typo
I thought that you might feel English or North American at different times.

Good that you have it working the way you want it.
Good luck

---

Hey Jolivanes,
Thanks for all the help with my problem. I just finished up all the formatting for my project and all the macro's were working perfectly, then all of a sudden my project page just stopped doing what it was doing. No errors nothing. I have no clue.
Think maybe you could take a look and help me out? The file is too big to upload tho.

Too bad. You had it working to your liking I thought.
However, without anything to look at and without knowing what you changed, which must have happened otherwise it would still be working, that gets difficult.

Before responding, please read, and maybe re-read, Post #10 again.

So I'm not sure why the code stopped randomly, but I'm able to get it working again with a new workbook.
Right now the code you gave me is perfect except for a little step i'd like to change.

Right now, the code works well but if all the QTY's are 0, the code still copies the bottom section.
Can I have the code only copy the ws IF the QTY's are not 0 and skip the whole sheet if they ARE all 0, till the first blank cell in column A?? There is always an empty cell between the last QTY and Labour so can I make the code stop there and only continue if there are NOT 0 values above?

I attached a copy so you can see what I mean.

First, in your above post delete the parts that were quoted. This was politely requested several times, not required here at all.

I have another question. The way I think you are using this is that you only use one sheet at the time to transfer (copy and paste) from. Is that right?
If so, there should be a better solution then what we have now.
Let us know if that is the case.

This should do what you asked for in Post #15 I think.

Code:

---

Sub Button1_Click()
    Dim pjWs As Worksheet, ws As Worksheet, i As Long, lr As Long
    Set pjWs = Worksheets("Project")
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Project" Then
            With ws
                lr = .Cells(.Rows.Count, 2).End(xlUp).Row
                If WorksheetFunction.Sum(.Range(.Cells(3, 1), .Cells(lr - 10, 1))) > 0 Then
                For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row - 6
                    If .Cells(i, 1).Value > 0 Then pjWs.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 4).Value = .Cells(i, 1).Resize(, 4).Value
                Next i
                If .Cells(lr - 4, 1).Value > 0 Then
                    pjWs.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(6, 4).Value = .Cells(lr - 5, 1).Resize(6, 4).Value
                End If
                End If
            End With
        End If
    Next ws
End Sub

---

Attached is another version as I mentioned in the previous post.

The code you just sent me works exactly!!! Thanks so much!
I'm going to take a look at the other one but we do use more than one page at a time sometimes.