dakkat
01-28-2011, 11:12 AM
Hello,
I have having difficulties creating a script that contains multiple Criteria. I have the code working with 1 If statement, but after adding a second, it runs but does not copy and paste any results.
I am matching on the datasheet, a Name (A Column) to the users tab Name (D3), and then based upon a match if the result on the datasheet (C Column) = "SHIFT" AND (E Column) = "YES" then copy the value in Column C).
Sub SHIFT()
Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long, c As Range, fDate As Date
With Worksheets("exc")
Set r = .Range(.Range("A7"), .Range("A7").End(xlDown))
End With
For Each cell In r
For Each sh In Worksheets
If LCase(sh.Name) <> "exc" Then
If sh.Cells(3, "D").Value = cell Then
If cell.Offset(0, 2).Value = "SHIFT" & cell.Offset(0, 4).Value = "YES" Then
cell.Offset(0, 3).Copy
fDate = cell.Offset(0, 1).Value
Set c = sh.Range("A46:A76").Find(fDate, LookIn:=xlValues)
If Not c Is Nothing Then
sh.Range("AD" & c.Row).PasteSpecial xlPasteValues
Else
End If
End If
End If
End If
Next
Next
End Sub
I can get it to work without the date search if I wanted to copy the value into a fixed cell. I can get it to work with a date match but with only one criteria. However, adding the secondary match criteria the code runs but does not copy anything.
The code below is another script that works fine, with copying a value after matching a date range with a single criteria. All I need to do is add a second criteria and cannot seem to make it work. Might be easier to say what I would need to do with the code below to add a second criteria and then I can just change the specifics to match the fields and columns.
Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long, c As Range, fDate As Date
With Worksheets("anew")
Set r = .Range(.Range("A7"), .Range("A7").End(xlDown))
End With
For Each cell In r
For Each sh In Worksheets
If LCase(sh.Name) <> "anew" Then
If sh.Cells(3, "D").Value = cell Then
If cell.Offset(0, 1).Value = "YES" Then
fDate = cell.Offset(0, 4).Value
Set c = sh.Range("A46:A76").Find(fDate, LookIn:=xlValues)
sh.Range("U" & c.Row) = cell.Offset(0, 8).Value / 100
sh.Range("AE" & c.Row) = cell.Offset(0, 6).Value / 24
End If
End If
End If
Next
Next
Any help would be greatly appreciated.
I have having difficulties creating a script that contains multiple Criteria. I have the code working with 1 If statement, but after adding a second, it runs but does not copy and paste any results.
I am matching on the datasheet, a Name (A Column) to the users tab Name (D3), and then based upon a match if the result on the datasheet (C Column) = "SHIFT" AND (E Column) = "YES" then copy the value in Column C).
Sub SHIFT()
Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long, c As Range, fDate As Date
With Worksheets("exc")
Set r = .Range(.Range("A7"), .Range("A7").End(xlDown))
End With
For Each cell In r
For Each sh In Worksheets
If LCase(sh.Name) <> "exc" Then
If sh.Cells(3, "D").Value = cell Then
If cell.Offset(0, 2).Value = "SHIFT" & cell.Offset(0, 4).Value = "YES" Then
cell.Offset(0, 3).Copy
fDate = cell.Offset(0, 1).Value
Set c = sh.Range("A46:A76").Find(fDate, LookIn:=xlValues)
If Not c Is Nothing Then
sh.Range("AD" & c.Row).PasteSpecial xlPasteValues
Else
End If
End If
End If
End If
Next
Next
End Sub
I can get it to work without the date search if I wanted to copy the value into a fixed cell. I can get it to work with a date match but with only one criteria. However, adding the secondary match criteria the code runs but does not copy anything.
The code below is another script that works fine, with copying a value after matching a date range with a single criteria. All I need to do is add a second criteria and cannot seem to make it work. Might be easier to say what I would need to do with the code below to add a second criteria and then I can just change the specifics to match the fields and columns.
Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long, c As Range, fDate As Date
With Worksheets("anew")
Set r = .Range(.Range("A7"), .Range("A7").End(xlDown))
End With
For Each cell In r
For Each sh In Worksheets
If LCase(sh.Name) <> "anew" Then
If sh.Cells(3, "D").Value = cell Then
If cell.Offset(0, 1).Value = "YES" Then
fDate = cell.Offset(0, 4).Value
Set c = sh.Range("A46:A76").Find(fDate, LookIn:=xlValues)
sh.Range("U" & c.Row) = cell.Offset(0, 8).Value / 100
sh.Range("AE" & c.Row) = cell.Offset(0, 6).Value / 24
End If
End If
End If
Next
Next
Any help would be greatly appreciated.