Code condition

[LiAD]

The following code is supposed to:

1) Delete all the entries on sheets 2-5, (named Urgences, Imperatifs,
Importants, Repariations), from cells B6 to J(end)
2) Copy any cells with a value of 10 in row K and an X in row V from Données
to Urgences, and this continues for all of the values 10,8,6,4,2 all going to
different sheets. In other others columns in Données I have a mix of number
entries, text enrties etc some of which come from drop down lists.

At the moment the code ONLY copies the data IF I have something written in
cell I - this should not be part of code. Whether or not something is
written in col I the code should copy the necessary data.

I have tried changing every other item in the list to see if there is
another condition affecting it - there is not.

Does anyone know why this would be happening and how to resolve it?

Thanks
LiAD



Private Sub Workbook_Open()
Dim lr As Long, rng As Range
Dim lr2 As Long, lr3 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws3 As Worksheet, ws4 As Worksheet
Dim ws5 As Worksheet
Set ws1 = Sheets("Données")
Set ws2 = Sheets("Urgences")
Set ws3 = Sheets("Imperatifs")
Set ws4 = Sheets("Importants")
Set ws5 = Sheets("Repariations")
ws2.Range("B6:J" & Cells(10, 2).End(xlDown).Row).Delete
ws3.Range("B6:J" & Cells(10, 2).End(xlDown).Row).Delete
ws4.Range("B6:J" & Cells(10, 2).End(xlDown).Row).Delete
ws5.Range("B6:J" & Cells(10, 2).End(xlDown).Row).Delete
lr = ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row
Set rng = ws1.Range("K9:K" & lr)
Application.DisplayAlerts = False
For Each c In rng

If c.Value = 2 And UCase(Range("v" & c.Row).Value) = "X" Then
lr2 = ws5.Cells(ws5.Rows.Count, 9).End(xlUp).Row
If lr2 < 6 Then lr2 = 5
Range("B" & c.Row & ":J" & c.Row).Copy ws5.Range("B" & lr2 + 1)

ElseIf c.Value = 4 And UCase(Range("v" & c.Row).Value) = "X" Then
lr2 = ws4.Cells(ws4.Rows.Count, 9).End(xlUp).Row
If lr2 < 6 Then lr2 = 5
Range("B" & c.Row & ":J" & c.Row).Copy ws4.Range("B" & lr2 + 1)

ElseIf c.Value = 6 And UCase(Range("v" & c.Row).Value) = "X" Then
lr2 = ws4.Cells(ws4.Rows.Count, 9).End(xlUp).Row
If lr2 < 6 Then lr2 = 5
Range("B" & c.Row & ":J" & c.Row).Copy ws4.Range("B" & lr2 + 1)

End If
Next

Set rng = ws1.Range("K9:K" & lr)
Application.DisplayAlerts = False
For Each c In rng

If c.Value = 8 And UCase(Range("v" & c.Row).Value) = "X" Then
lr2 = ws3.Cells(ws3.Rows.Count, 9).End(xlUp).Row
If lr2 < 6 Then lr2 = 5
Range("B" & c.Row & ":J" & c.Row).Copy ws3.Range("B" & lr2 + 1)

ElseIf c.Value = 10 And UCase(Range("v" & c.Row).Value) = "X" Then
lr3 = ws2.Cells(ws2.Rows.Count, 9).End(xlUp).Row
If lr3 < 6 Then lr3 = 5
Range("B" & c.Row & ":J" & c.Row).Copy ws2.Range("B" & lr3 + 1)

End If
Next
Application.DisplayAlerts = True
ThisWorkbook.Save
End Sub

 

[john]

Do not have time to test your code but just an idea, I note that although you
have created an object reference to each worksheet, you have not qualified
some of the Range & Cell checks / tests to them - it may be, the your code
is returning results from the wrong sheet & this is why it fails??

I have added what I think you have omitted but check then see if this helps.

Private Sub Workbook_Open()
Dim lr As Long, rng As Range
Dim lr2 As Long, lr3 As Long
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws3 As Worksheet, ws4 As Worksheet
Dim ws5 As Worksheet

Set ws1 = Sheets("Données")
Set ws2 = Sheets("Urgences")
Set ws3 = Sheets("Imperatifs")
Set ws4 = Sheets("Importants")
Set ws5 = Sheets("Repariations")

ws2.Range("B6:J" & ws2.Cells(10, 2).End(xlDown).Row).Delete
ws3.Range("B6:J" & ws3.Cells(10, 2).End(xlDown).Row).Delete
ws4.Range("B6:J" & ws4.Cells(10, 2).End(xlDown).Row).Delete
ws5.Range("B6:J" & ws5.Cells(10, 2).End(xlDown).Row).Delete

lr = ws1.Cells(ws1.Rows.Count, "K").End(xlUp).Row

Set rng = ws1.Range("K9:K" & lr)

Application.DisplayAlerts = False

For Each c In rng

If c.Value = 2 And UCase(ws1.Range("v" & c.Row).Value) = "X" Then

lr2 = ws5.Cells(ws5.Rows.Count, 9).End(xlUp).Row

If lr2 < 6 Then lr2 = 5

ws1.Range("B" & c.Row & ":J" & c.Row).Copy ws5.Range("B" & lr2 +
1)

ElseIf c.Value = 4 And UCase(ws1.Range("v" & c.Row).Value) = "X" Then

lr2 = ws4.Cells(ws4.Rows.Count, 9).End(xlUp).Row

If lr2 < 6 Then lr2 = 5

ws1.Range("B" & c.Row & ":J" & c.Row).Copy ws4.Range("B" & lr2 +
1)

ElseIf c.Value = 6 And UCase(ws1.Range("v" & c.Row).Value) = "X" Then

lr2 = ws4.Cells(ws4.Rows.Count, 9).End(xlUp).Row

If lr2 < 6 Then lr2 = 5

ws1.Range("B" & c.Row & ":J" & c.Row).Copy ws4.Range("B" & lr2 +
1)

End If
Next

Set rng = ws1.Range("K9:K" & lr)
Application.DisplayAlerts = False
For Each c In rng

If c.Value = 8 And UCase(ws1.Range("v" & c.Row).Value) = "X" Then

lr2 = ws3.Cells(ws3.Rows.Count, 9).End(xlUp).Row

If lr2 < 6 Then lr2 = 5

ws1.Range("B" & c.Row & ":J" & c.Row).Copy ws3.Range("B" & lr2 +
1)

ElseIf c.Value = 10 And UCase(ws1.Range("v" & c.Row).Value) = "X" Then
lr3 = ws2.Cells(ws2.Rows.Count, 9).End(xlUp).Row
If lr3 < 6 Then lr3 = 5

ws1.Range("B" & c.Row & ":J" & c.Row).Copy ws2.Range("B" & lr3 +
1)

End If
Next

Application.DisplayAlerts = True

ThisWorkbook.Save

End Sub

 

[Sam Wilson]

Hi LiAD,

It will copy data where cell I is empty, but it'll then overwrite it with
the next row. You have this:

lr2 = ws5.Cells(ws5.Rows.Count, 9).End(xlUp).Row

In various places - that's looking for the last cell in column I, so if that
cell is blank then the row will be copied over. Maybe change that 9 to a
different number to use a column that's always populated.

Sam

 

[LiAD]

Perfect.

Problem fixed.

Thanks a lot

Hi LiAD,

It will copy data where cell I is empty, but it'll then overwrite it with
the next row. You have this:

lr2 = ws5.Cells(ws5.Rows.Count, 9).End(xlUp).Row

In various places - that's looking for the last cell in column I, so if that
cell is blank then the row will be copied over. Maybe change that 9 to a
different number to use a column that's always populated.

Sam