PDA

View Full Version : Solved: VBA - Range and value match and replace



dakkat
05-25-2010, 01:05 PM
Hello,

I have been working on this code for a while now and am having some issues that I would like to see if I can get a solution for. I have a workbook with over 100 worksheets. Each worksheet that I want to run this code on are using the same template.

The code below is running but not as I would like. Here is the scenario:



Sub Offline()

Dim r As Range, cell As Range, sh As Worksheet
Dim lastrow As Long, c As Range, fDate As Date
Dim i As String

i = "Project Time"

With Worksheets("Sheet13 (64)")
Set r = .Range(.Range("E52"), .Range("E52").End(xlDown))
End With


For Each cell In r
For Each sh In Worksheets
If cell.Value = i Then
fDate = cell.Offset(0, -2).Value
cell.Offset(0, 3).Copy
Set c = sh.Range("A17:A47").Find(fDate, LookIn:=xlValues)
If Not c Is Nothing Then
sh.Range("C" & c.Row).PasteSpecial xlPasteValues
sh.Range("E" & c.Row).PasteSpecial xlPasteValues
sh.Range("F" & c.Row).PasteSpecial xlPasteValues
sh.Range("G" & c.Row).PasteSpecial xlPasteValues
sh.Range("H" & c.Row).PasteSpecial xlPasteValues
sh.Range("I" & c.Row).PasteSpecial xlPasteValues
sh.Range("J" & c.Row).PasteSpecial xlPasteValues
sh.Range("K" & c.Row).PasteSpecial xlPasteValues
sh.Range("L" & c.Row).PasteSpecial xlPasteValues
sh.Range("M" & c.Row).PasteSpecial xlPasteValues
sh.Range("N" & c.Row).PasteSpecial xlPasteValues
sh.Range("O" & c.Row).PasteSpecial xlPasteValues
sh.Range("P" & c.Row).PasteSpecial xlPasteValues
sh.Range("Q" & c.Row).PasteSpecial xlPasteValues
sh.Range("R" & c.Row).PasteSpecial xlPasteValues
sh.Range("T" & c.Row).PasteSpecial xlPasteValues
sh.Range("U" & c.Row).PasteSpecial xlPasteValues
sh.Range("V" & c.Row).PasteSpecial xlPasteValues
sh.Range("W" & c.Row).PasteSpecial xlPasteValues
sh.Range("X" & c.Row).PasteSpecial xlPasteValues
sh.Range("Y" & c.Row).PasteSpecial xlPasteValues
sh.Range("Z" & c.Row).PasteSpecial xlPasteValues
sh.Range("AA" & c.Row).PasteSpecial xlPasteValues
sh.Range("AB" & c.Row).PasteSpecial xlPasteValues
sh.Range("AC" & c.Row).PasteSpecial xlPasteValues
sh.Range("AQ" & c.Row).PasteSpecial xlPasteValues
End If
End If
Next
Next

End Sub

Issues:
1) I would like to just delete the values in the cells but instead, I am copying a blank cell and pasting it into the cells I want cleared.

2) This test is running on all worksheets and I need a way to have it run for each worksheet separately. (Currently using values on "Sheet13 (64)" to delete on all worksheets. Would like to specify something like below to identify which worksheets to run this script on (each worksheet that has an email address in the C3 field):

For Each ws In ActiveWorkbook.Worksheets
If ws.Range("C3").Value Like "?*@?*.?*" Then

So basically, I am setting a range from E52 down until no values and if any cell in that range is equals 'Project Time' it is looking that the date 2 cells to the left and then taking that date and finding a match in the range of "A17:A47" and when found it is to clear the multiple cell values in that row.

There has to be an easier way to clear values than copying a blank cell and pasting it like my code is doing.

Please, any assistance would be greatly appreciated.

Thank you,

dakkat
05-25-2010, 01:23 PM
One more thing I forgot to add. I need to add an AND to the cell value before setting the fDate.

If cell.Value = i AND 'cell value to its immediate left is blank' Then

dakkat
05-26-2010, 06:21 AM
I was able to figure it out. For those that may wish to know how to do this I have posted the code below:


Sub Offline()

Dim RNG As Range, cell As Range, c As Range
Dim sh As Worksheet
Dim fDate As Date
Dim MyStr As String: MyStr = "Project Time"

For Each sh In Worksheets
If InStr(sh.Range("C3"), "@") > 0 Then
Set RNG = sh.Range("E52", sh.Range("E52").End(xlDown))

For Each cell In RNG
If cell.Value = MyStr And cell.Offset(0, -1) = "" Then
fDate = cell.Offset(0, -2).Value
Set c = sh.Range("A17:A47").Find(fDate, LookIn:=xlValues)
If Not c Is Nothing Then
sh.Range("C" & c.Row).ClearContents
sh.Range("E" & c.Row, "R" & c.Row).ClearContents
sh.Range("T" & c.Row, "AC" & c.Row).ClearContents
sh.Range("AQ" & c.Row).ClearContents
Set c = Nothing
End If
End If
Next cell

Set RNG = Nothing
End If
Next sh

End Sub