I have data on Worksheets("North").Range("B3:B500") , and data on Worksheets("Auto").Range("A2:A22") in the same workbook.
How to check If every Cell in first Range found on the second Range, and if it exists, some code will run (Offset )?
The problem on the below code in this line:
If Cell.value = Worksheets("Auto").Range("A2:A22") Then
Sub Check_Range()
Dim WorkOrder As Range
Dim Closed_Data As Range
Dim Cell As Object
Set WorkOrder = Worksheets("North").Range("B3:B500")
Set Closed_Data = Worksheets("Auto").Range("A2:A22")
For Each Cell In WorkOrder
If Cell.value = Worksheets("Auto").Range("A2:A22") Then
Cell.Offset(, 6).value = "Close"
Cell.Offset(, 7).value = Now
End If
Next Cell
End Sub
It is not possible to compare the value of one cell to a range. Try this code:
Sub Check_Range()
Dim WorkOrder As Range
Dim Closed_Data As Range
Dim Cell As Object
Set WorkOrder = Worksheets("North").Range("B3:B500")
Set Closed_Data = Worksheets("Auto").Range("A2:A22")
On Error Resume Next
For Each Cell In WorkOrder
With Cell
WorksheetFunction.Match .Value, Closed_Data, 0 'value search
If Err.Number = 0 Then ' if there is no error, then the value was found
.Offset(, 6).Value = "Close"
.Offset(, 7).Value = Now
End If
Err.Clear
End With
Next Cell
On Error GoTo 0
End Sub
Related
I have this small piece of code.
Sub FillRemainingDates()
Dim SearchRange As Range
Set SearchRange = Sheets(1).UsedRange.Columns(11)
Dim cell As Range
For Each cell In SearchRange
If cell.Value = vbNullString And cell.Offset(0, 9).Value = cell.Offset(1, 9).Value Then
cell = cell.Offset(1, 0).Value
End If
Next
End Sub
Its goal is to attribute a value to a cell in a column depending on the value of a cell a row below:
The macro "works" in the sense that it does what I expect it to do, but whenever I run it it causes the program to become unresponsive and freeze for a long time.
I think I'm missing something in the loop and it's causing the program to fall into an infinite loop or have to deal with more data than necessary.
You should use an array to work on - and then write that back to the sheet.
Sub FillRemainingDates()
'ASSUMPTION: data start in column A
'>>> change the names according to your project
Const colNameOfColumn11 As Long = 11
Const colNameOfColumn20 As Long = 20
Dim arrSearch As Variant
arrSearch = Worksheets(1).UsedRange
Dim i As Long
Dim varValue As Variant '>>>> change type according to your values
For i = 1 To UBound(arrSearch, 1) - 1 ' don't check last row
varValue = arrSearch(i, colNameOfColumn11)
If varValue = vbNullString And _
arrSearch(i, colNameOfColumn20) = arrSearch(i + 1, colNameOfColumn20) Then
arrSearch(i, colNameOfColumn11) = arrSearch(i + 1, colNameOfColumn11)
End If
Next
Worksheets(1).UsedRange.Value = arrSearch
End Sub
if Column "A" was empty how can i make excel assign unique no# to unique cells and duplicated no# to duplicated cells just like the image attached.
While I am sure there is probably an easier way to accomplish your task, this one seems to work okay (disclaimer: lightly tested).
So essentially, serialNumber attempts to find the highest value in Col A. If none is found, it's assigned a value of 1.
RetCel attempts to set itself to a previous cell that matches. If no match is found, it will assign the current serialNumber value. If a match is found, then it will use the value of the match.
serialNumber only increases itself when the value has been used.
Option Explicit
Sub AssignUnique()
On Error GoTo ErrHandler
Dim ws As Worksheet, RngA As Range, RngB As Range, cel As Range
Set ws = ThisWorkbook.Worksheets("Sheet3")
Set RngA = ws.UsedRange.Columns("A")
Set RngB = ws.UsedRange.Columns("B")
If RngA.Column = 2 Then
'In the event RngA is empty, UsedRange will make it col B
Set RngA = RngA.Offset(, -1)
Set RngB = RngB.Offset(, -1)
If RngA.Column <> 1 Then
Err.Raise vbObjectError + 1000, , "Error setting RngA"
End If
End If
Dim RetCel As Range, serialNumber As Long
serialNumber = WorksheetFunction.Max(RngA)
If serialNumber = 0 Then serialNumber = 1
For Each cel In RngB.Cells
Set RetCel = Nothing
On Error Resume Next
Set RetCel = ws.Cells.Find(cel.Value, After:=Cells(cel.Row - 1, 2), _
SearchDirection:=xlPrevious)
Debug.Print RetCel.Address
On Error GoTo ErrHandler
If cel.Value = vbNullString Then
'Do Nothing
ElseIf RetCel Is Nothing Then
cel.Offset(, -1).Value = serialNumber
serialNumber = serialNumber + 1
Else
cel.Offset(, -1).Value = RetCel.Offset(, -1).Value
If cel.Offset(, -1).Value = vbNullString Then
cel.Offset(, -1).Value = serialNumber
serialNumber = serialNumber + 1
End If
End If
Next cel
Exit Sub
ErrHandler:
MsgBox Err.Description, vbCritical, "Runtime # " & Err.Number
End Sub
I have this code:
Sub yeartest()
Dim cell As Range
storeval = 0
For Each cell In Range("I7:I17")
If cell.Value = "THISVALUE" Then
Let storeval = cell.Offset(-1, 0).Value
End If
Range("Q18").Activate
ActiveCell.Formula = "=SUM(storeval)"
Next cell
End Sub
What the code should do is analyze the range I7:I17. Everytime it encounters a cell in this range with the value THISVALUE it should go right by one cell and store that value. After the entire range has been analyzed the sum of all cells one right of THISVALUE should be output in cell Q18.
Currently cell Q18 just displays a #NONAME value when I execute the macro.
Sub yeartest()
Dim cll As Range
storeval = 0
For Each cll In Range("I7:I17")
If cell.Value = "THISVALUE" Then
storeval = storeval + cell.Offset(-1, 0).Value
End If
Next cll
Range("Q18")=storeval
End Sub
Sorry I am a novice in VBA so any help is gratefully received!
I'm looking for some VBA code for a loop that will look at a range in Column A and as long as the cell in Column A is not 0, replace the adjacent cell in Column B with the positive value, looping through the range until all cells with data > 0 in Column A have been replaced in Column B. It is also important that blank cells in Column A do not overwrite positive data that may exist in Column B.
This is where I am at the moment:
Sub Verify()
Dim rng As Range
Dim i As Long
'Set the range in column N
Set rng = Range("N2:n1000")
For Each cell In rng
'test if cell = 0
If cell.Value <> 0 Then
'write value to adjacent cell
cell.Offset(0, -2).Value = *'What do I need here to find the first item of data e.g. N2 in column N?'*
End If
Next
End Sub
Many thanks
I think it would be easier to deal with ActiveSheet.Cells as with Range object and offsets :
Sub Verify()
Dim row As Long
For row = 2 To 1000
If ActiveSheet.Cells(row,1) <> "" Then ' Not blank
If ActiveSheet.Cells(row,1) > 0 Then ' Positive
ActiveSheet.Cells(row,2) = ActiveSheet.Cells(row,1)
End If
End If
Next
End Sub
This is the edit to what you started. I made the range dynamic, because I don't like making excel loop longer than it has to. That's my personal preference. The first block of code will copy over anything that isn't 0 or blank, and any negative numbers will be represented by their positive counterpart. That's at least how I understood your question.
Also, this code looks at data in Col N (like you have in your code) and copies the data to Col L. If you want A to B then simply change rng to = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp)) and the myCell.Offset() to (0, 1).
Sub Verify()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets(1) 'good form to always define the sheet you're working on
Set rng = ws.Range("N2", ws.Cells(ws.Rows.Count, "N").End(xlUp)) 'dynamic range
For Each myCell In rng
If myCell.Value <> "" And myCell.Value <> 0 Then 'If the cell isn't 0 or ""
If myCell.Value < 0 Then 'Then if it's negative, make it positive and copy it over
myCell.Offset(0, -2).Value = myCell.Value * -1
Else: myCell.Offset(0, -2).Value = myCell.Value 'otherwise copy the value over
End If
End If
Next myCell
End Sub
If you only want to copy over values that are greater than 0, and ignore 0's, blanks, and negative values, then use this code:
Sub Verify()
Dim ws As Worksheet
Dim rng As Range
Set ws = ThisWorkbook.Sheets(1) 'good form to always define the sheet you're working on
Set rng = ws.Range("N2", ws.Cells(ws.Rows.Count, "N").End(xlUp)) 'dynamic range
For Each myCell In rng
If myCell.Value <> "" And myCell.Value > 0 Then 'If the cell is > 0 and not ""
myCell.Offset(0, -2).Value = myCell.Value 'copy the value over
End If
Next myCell
End Sub
If I understand your question correctly, you can "simplify" it to something like this:
Sub Verify()
[b2:b1000] = [if(iferror(-a2:a1000,),abs(a2:a1000),b2:b1000&"")]
End Sub
just replace a2:a1000 with your Column A range and b2:b1000 with the Column B range.
How can I create a macro that will add a day in one cell and subtract a day in another cell at the same time? Here is what I have so far.
Sub ChangeDates()
Dim cell As Range
For Each cell In Range("B:B")
cell.Value = cell.Value + 1
Next cell
For Each cell In Range("C:C")
cell.Value = cell.Value - 1
End Sub
I know you've accepted an answer, but I would like to offer this approach, which is even faster and more efficient than looping through all those cells.
If your dates are in Column A, then Column B will hold date +1 and Column C will hold date -1
Option Explicit
Sub ChangeDates()
Dim myRange As range
Dim mySheet As Worksheet
Set mySheet = Sheets("Sheet7") 'change to your sheet
With mySheet
Set myRange = .range("A1:A" & .range("A" & .Rows.Count).End(xlUp).Row)
myRange.Offset(, 1).FormulaR1C1 = "=RC[-1]+1"
myRange.Offset(, 2).FormulaR1C1 = "=RC[-2]-1"
End With
End Sub
Offset to the rescue!!
Sub ChangeDates()
Dim cell As Range
For Each cell In Range("B:B")
cell.Value = cell.Value + 1
cell.offset(0,1).value = cell.offset(0,1).value - 1
Next cell
End Sub
Another thing you may consider is either looking at usedrange to not have to iterate through all of column B or put in a check to make sure the cells aren't blank... Just faster, better coding and stops you from having bad values where the cells were originally blank...
Sub ChangeDates()
Dim cell As Range
For Each cell In Intersect(Range("B:B"), ActiveSheet.UsedRange)
cell.Value = cell.Value + 1
cell.Offset(0, 1).Value = cell.Offset(0, 1).Value - 1
Next cell
End Sub