PDA

View Full Version : Copy / Display row from another sheet



Mortimer
04-17-2017, 06:56 PM
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.



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

jolivanes
04-18-2017, 01:27 PM
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.

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

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

Mortimer
04-18-2017, 04:35 PM
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.

jolivanes
04-18-2017, 06:23 PM
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.

Mortimer
04-19-2017, 01:00 PM
My Project Sheet:

18966
My "Active work sheet"

18967

Here is my 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.

jolivanes
04-19-2017, 02:59 PM
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.

Mortimer
04-19-2017, 03:16 PM
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!

jolivanes
04-19-2017, 07:08 PM
Your CommandButton1 code could be changed to:

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.

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

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?

Mortimer
04-20-2017, 05:11 AM
YES YES YES!!! thank you so much!!!! works perfectly!

Labor and Labour is be a typo, lol

mdmackillop
04-20-2017, 05:38 AM
Please don't quote entire posts. Quote only what is relevant to your question.

Mortimer
04-20-2017, 05:51 AM
Sorry.

jolivanes
04-20-2017, 11:42 PM
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

Mortimer
05-13-2017, 01:45 PM
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.

jolivanes
05-13-2017, 10:34 PM
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.

Mortimer
05-15-2017, 09:33 AM
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.

jolivanes
05-15-2017, 10:43 AM
First, in your above post delete the parts that were quoted. This was politely requested several times, not required here at all.

jolivanes
05-15-2017, 12:19 PM
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.

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

jolivanes
05-15-2017, 12:34 PM
Attached is another version as I mentioned in the previous post.

Mortimer
05-15-2017, 01:18 PM
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.