Copying worksheet A values into worksheet B - missing cell values

[huge_ness]

Hi,

I am trying to copy column values from the worksheet entitled "Stage
Forecast" to another worksheet called "Training Dashboard". I have written up
most of the code however during the transfer, not all the data is copying
over. As you can see from the code, I am mainly concerned with data that is
found in column J of the "Training Dashboard" worksheet. If column Y of
"Stage Forecast" has any cells that are empty, I do not display its row.

Also within column Y of "Stage Forecast", it is a date field that is either
shown underlined, or crossed out (meaning completed). I am only receiving
data that is crossed out using this code. I need to alter what is shown below
so that the data that is transmitted is only those rows in which row Y has a
date that is simply underlined.

Secondly as a secondary piece of code: I need my second worksheet "Training
Dashboard" to not show duplicate information once I click the the command
button to update the sheet.

Any help would be greaty appreciated,

Thanks.

VB code:

Sub CommandButton1_Click()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myrange, MyRange1 As Range
Application.ScreenUpdating = False

Set WS1 = Worksheets("Stage Forecast")
Set WS2 = Worksheets("Training Dashboard")

WS1.Range("K1:K330").Copy WS2.Cells(Rows.Count, "D").End(xlUp)
WS1.Range("L1:L330").Copy WS2.Cells(Rows.Count, "E").End(xlUp)
WS1.Range("M1:M330").Copy WS2.Cells(Rows.Count, "F").End(xlUp)
WS1.Range("N1:N330").Copy WS2.Cells(Rows.Count, "G").End(xlUp)
WS1.Range("O1:O330").Copy WS2.Cells(Rows.Count, "H").End(xlUp)
WS1.Range("Q1:Q330").Copy WS2.Cells(Rows.Count, "I").End(xlUp)
WS1.Range("Y1:Y330").Copy WS2.Cells(Rows.Count, "J").End(xlUp)

LastRow = Cells(Rows.Count, "J").End(xlUp).Row
Set myrange = Sheets("Training Dashboard").Range("J3:J" & LastRow)
For Each c In myrange
If UCase(c.Value) = "" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If

End Sub

 

[Joel]

I think the cause of the problem is the LastRow statement the "CELLS" didn't
specify a sheet and may of been refereing to the wrong sheet to get the last
row. Try these changes. Your code was also over-writing the last row of
data using just XLUP. You want to put new data in the next row after the
XLUP. I assumed all the columns had data in the last row and used column J
to determine the last row.


Sub CommandButton1_Click()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myrange, MyRange1 As Range
Application.ScreenUpdating = False

Set WS1 = Worksheets("Stage Forecast")
Set WS2 = Worksheets("Training Dashboard")

with WS1

LastRow = .Cells(Rows.Count, "J").End(xlUp).Row
NewRow = LastRow + 1
.Range("K1:K330").Copy WS2.Cells(NewRow, "D")
.Range("L1:L330").Copy WS2.Cells(NewRow, "E")
.Range("M1:M330").Copy WS2.Cells(NewRow, "F")
.Range("N1:N330").Copy WS2.Cells(NewRow, "G")
.Range("O1:O330").Copy WS2.Cells(NewRow, "H")
.Range("Q1:Q330").Copy WS2.Cells(NewRow, "I")
.Range("Y1:Y330").Copy WS2.Cells(NewRow, "J")

Set myrange = WS2.Range("J3:J" & LastRow)
For Each c In myrange
If UCase(c.Value) = "" Then
If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next

If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If
end with
End Sub

 

[huge_ness]

Hi Joel,

Thanks for the reply. I ran your code, however I am facing a similar issue
as I once did during testing. When I run your code, all rows are shown.
However, in doing so I realized that cells that are being carried over are
not missing, there seems to be a formatting error that makes all dates in the
Y column in question: crossed out.

With that, we wouldn't be able to classify what is still active and what is
not.
I would like the J column to show only those rows in which the Y column of
"Stage Forecast" are valid dates that are still active, thus not crossed out.

Also, when I'm using your code, it updates the field by adding all the rows
on top of one another, so I get duplicated of the data.

Thanks,
Mark

 

[Joel]

I added an OR statement to remove the lines with column Y containing a
STRIKETHROUGH. Make sure there isn't any conditional formating in column J
that is producing the strikeout. The code below will not remove the lines
with the strikeout if the strinkout is being generated by conditional
formating.

Sub CommandButton1_Click()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myrange, MyRange1 As Range
Application.ScreenUpdating = False

Set WS1 = Worksheets("Stage Forecast")
Set WS2 = Worksheets("Training Dashboard")

With WS1

LastRow = .Cells(Rows.Count, "J").End(xlUp).Row
NewRow = LastRow + 1
.Range("K1:K330").Copy WS2.Cells(NewRow, "D")
.Range("L1:L330").Copy WS2.Cells(NewRow, "E")
.Range("M1:M330").Copy WS2.Cells(NewRow, "F")
.Range("N1:N330").Copy WS2.Cells(NewRow, "G")
.Range("O1:O330").Copy WS2.Cells(NewRow, "H")
.Range("Q1:Q330").Copy WS2.Cells(NewRow, "I")
.Range("Y1:Y330").Copy WS2.Cells(NewRow, "J")

Set myrange = WS2.Range("J3:J" & LastRow)
For Each C In myrange
If C.Value = "" Or _
C.Font.Strikethrough = True Then

If MyRange1 Is Nothing Then
Set MyRange1 = C.EntireRow
Else
Set MyRange1 = Union(MyRange1, C.EntireRow)
End If
End If
Next

If Not MyRange1 Is Nothing Then
MyRange1.Delete
End If
End With
End Sub

 

[huge_ness]

The problem is that from the Source worksheet ("Stage Forecast"), all the
data is maintained through conditional formatting. Therefore the or statement
would not affect it as you mentioned previously.

Is there a way to read the cells contents with conditional fomatting?

 

[Joel]

Chip Pearson has an article discussing conditional formating

http://www.cpearson.com/Excel/CFColors.htm

It is complicated to test if the conditional formating is causing the strike
through. It is simplier to duplicate the formula that is producing the
strikeout in VBA code. If the strikeout is testing if a date is older than 6
months than simply put in the VBA code a test for 6 months rahter than
looking at the conditional format inside the cell to determine if a stikeout
has occured.

 

[huge_ness]

Hi,

Sorry for not getting back to you sooner with regards to this. I read his
article and I agree that testing is too far fetched for my purposes here. So
in light of your idea, how could I " duplicate the formula that is producing
the strikeout in VBA code?"

Seeing as I am not an avid coder.

Thanks,

Mark

 

[Joel]

Post the formula and I will show you how. there are a few ways. of doing it.

 

[huge_ness]

There are 9 conditional fomulas applied to the column:
1. =NOT(AND(YEAR(S262)=YEAR(D262),MONTH(S262)=MONTH(D262)))
2. =AND(YEAR(S262)<=YEAR($C262),MONTH(S262)<MONTH($C262))
3. =NOT(AND(YEAR(S4)=YEAR(D4),MONTH(S4)=MONTH(D4)))
4. =AND(YEAR(S4)<=YEAR($C4),MONTH(S4)<MONTH($C4))
5. =NOT(AND(YEAR(X62)=YEAR(H62),MONTH(X62)=MONTH(H62)))
6. =AND(YEAR(X62)<=YEAR($C62),MONTH(X62)<MONTH($C62))
7. Cell Value = $P$345 # highlight in red
8. Cell Value = $Q$345 # highlight in red
9. Cell Value = $R$345 # highlight in red

 

[Joel]

Which formulas, under the font options, is producing the Cross outs?

Formual 1 : The month and year in colums D and S don't match
Formual 2 : The month and year in colums C and S are over 13 months old, but
doesn't cover the case where the 13 months wrap over two physical years.
Note the 13 month is because of the less than sign (not less than equal)

works for where April is greater than March
April 2009 and March 2008
Doesn't work for because January is Less than December
Jan 2009 and Dec 2007

Formual 3 : Looks the same as formula 1
Formual 4 : Looks the same as formula 2
Formual 5 : Looks the same as formula 1 except columns H and X
Formual 6 : Looks the same as formula 2 except columns C and X

 

[huge_ness]

All formulas 1 - 6 are producing cross outs. And as for 7-9, it does not
highlight the cell red, rather created a red border.

 

[Joel]

I don't know why there is a reference to row 4, row 62, and row 262. Because
the formulas overlap it looks like if we impliment the following

Only using the current row
If the month doesn't match in Columns S and D
or
If the month in Date in column S is older than 1 year than date in column C.

to get the 1 year date I will take the date in column C and go to the
beginning of the month. then subtract 1 year and look for dates older than
this date

If the date was Sept 24 2009 in column C remove lines with column S less
than Sept 1 2008.

 

[huge_ness]

Hi Joel,

Thanks for your help thus far. Now how can I implement this pseudocode in
code within the sub?

 

[Joel]

Something like this. I commented out the delte row and made the rows color 8
(blue) so you can see if the correct lines are being deleted before you
actually remove the rows.

Sub CommandButton1_Click()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim myrange, MyRange1 As Range
Application.ScreenUpdating = False

Set WS1 = Worksheets("Stage Forecast")
Set WS2 = Worksheets("Training Dashboard")

With WS1

LastRow = .Cells(Rows.Count, "J").End(xlUp).Row
NewRow = LastRow + 1
.Range("K1:K330").Copy WS2.Cells(NewRow, "D")
.Range("L1:L330").Copy WS2.Cells(NewRow, "E")
.Range("M1:M330").Copy WS2.Cells(NewRow, "F")
.Range("N1:N330").Copy WS2.Cells(NewRow, "G")
.Range("O1:O330").Copy WS2.Cells(NewRow, "H")
.Range("Q1:Q330").Copy WS2.Cells(NewRow, "I")
.Range("Y1:Y330").Copy WS2.Cells(NewRow, "J")

With WS2
Set myrange = .Range("J3:J" & LastRow)
For Each c In myrange
DeleteRow = False
If c.Value = "" Then
DeleteRow = True
Else
If Month(.Range(c.Row, "S")) <> Month(.Range(c.Row, "D")) Then
DeleteRow = True
Else
'start of month of previous year
LastYearSOM = DateSerial(Year(.Range("C" & c.Row)) - 1, _
Month(.Range("C" & c.Row)), 1)
If .Range(c.Row, "S") < LastYearSOM Then
DeleteRow = True
End If
End If
End If

If c.Value = "" Or _
DeleteRow = True Then

If MyRange1 Is Nothing Then
Set MyRange1 = c.EntireRow
Else
Set MyRange1 = Union(MyRange1, c.EntireRow)
End If
End If
Next
End With
If Not MyRange1 Is Nothing Then
MyRange1.interior.colorindex = 8
'MyRange1.Delete
End If
End With
End Sub

 

[huge_ness]

Hi Joel,

For some reason this is creating bugs within the copy. If I can get your
email, I can send you a copy of my workbook, and you can take a look
internally at what might be going wrong?

 

[Joel]

joel dot warburg at itt dot com

Hi Joel,

For some reason this is creating bugs within the copy. If I can get your
email, I can send you a copy of my workbook, and you can take a look
internally at what might be going wrong?

 

[huge_ness]

I have snet the attachment...let me know if you need anything else.
Thanks,

Mark