If column A contains "RR" and column C is not equal to "memo" and column E is not equal to "Air" or "Printed" then column L=0.
Then followed by If column A contains "RR" and column C is not equal to "memo" and column E is equal to "Air" or "Printed" then column L= is column H*.1.
I believe I am having trouble with equals/not equals.
Sub RRClean()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim myString As String
RowCount = WorksheetFunction.CountA(range("A:A"))
For i = 2 To RowCount
myString = Trim(Cells(i, 2).Value)
If InStr(myString, "RR") > 0 And .cell(i, 3) <> "Memo" And .cell(i, 7) <> "Air" Or .cell(i, 7) <> "Printed" Then
Cells(i, 12).Value = 0
End If
Next
For i = 2 To RowCount
myString = Trim(Cells(i, 2).Value)
If InStr(myString, "RR") > 0 And .cell(i, 3) <> "Memo" And .cell(i, 7) = "Air" Or .cell(i, 7) = "Printed" Then
Cells(i, 12).Value = cell(i, 8) * 0.1
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Your logic is slightly flawed when dealing with "and column E is not equal to "Air" or "Printed"". If a cell is not Air it could be Printed. If it is not Printed then it could be Air. You need And here as in "and column E is not equal to "Air" and column E is not equal to "Printed".
Sub Cmemo()
With Worksheets("Sheet4") '<~~ SET THIS WORKSHEET REFERENCE PROPERLY!!
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.AutoFilter Field:=1, Criteria1:="*RR*"
.AutoFilter Field:=3, Criteria1:="<>memo"
.AutoFilter Field:=5, Criteria1:="<>Air", _
Operator:=xlAnd, Criteria2:="<>Printed"
If CBool(Application.Subtotal(103, .Offset(1, 0).Cells)) Then
With .Resize(.Rows.Count - 1, 1).Offset(1, 11)
.SpecialCells(xlCellTypeVisible) = 0
End With
End If
.AutoFilter Field:=5, Criteria1:="Air", _
Operator:=xlOr, Criteria2:="Printed"
If CBool(Application.Subtotal(103, .Offset(1, 0).Cells)) Then
With .Resize(.Rows.Count - 1, 1).Offset(1, 11)
.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=rc[-4]/10"
End With
End If
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
Using the AutoFilter Method, both operations can be accomplished without declaring a single variable.
Related
I am writing a program that should sum only the row with a lower case c. The code I have now, sums all rows beginning with c, regardless if upper or lower case. How I can I write it so that it is case sensitive?
Here is what I have so far:
Sub summ()
Dim iArea As Long
With Worksheets("K00304.RPT")
With .Range("A14", .Cells(.Rows.Count, 1).End(xlUp))
.Cells(2, 1).Value = "ZERO"
.AutoFilter field:=1, Criteria1:="ZERO*"
With .Resize(.Rows.Count -
1).Offset(1).SpecialCells(xlCellTypeVisible) '.Offset(-1)
For iArea = 1 To .Areas.Count - 1
With .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea +
1).Offset(-1))
Worksheets("Total").Cells(Rows.Count,
"AF").End(xlUp).Offset(1).Value = WorksheetFunction.SumIf(.Cells, "c*",
.Offset(, 7))
End With
Next
End With
.Cells(2, 1).ClearContents
End With
.AutoFilterMode = False
End With
Many Thanks!
You can compare the characters with StrConv():
Sub t()
Dim cel As Range
Set cel = Range("A1")
If StrConv(Left(cel, 1), vbProperCase) = Left(cel, 1) And Left(cel, 1) = "C" Then
'There's a match, the left letter is capitalized.
Debug.Print "'C' is present"
End If
End Sub
Edit: Actually, just checking If LEFT(cel,1) = "C" Then seems to work too.
I would use the Evaluate function and sumproduct formula, hopefully this works.
Sub summ()
Dim iArea As Long
With Worksheets("K00304.RPT")
With .Range("A14", .Cells(.Rows.Count, 1).End(xlUp))
.Cells(2, 1).Value = "ZERO"
.AutoFilter field:=1, Criteria1:="ZERO*"
With .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) '.Offset(-1)
For iArea = 1 To .Areas.Count - 1
With .Parent.Range(.Areas(iArea).Offset(1), .Areas(iArea + 1).Offset(-1))
Dim criteria_range As String
Dim sum_range As String
Dim criteria As String
Dim sum_ifs_case_sensitive As Long
criteria = "c"
criteria_range = .Cells.Address
sum_range = .Offset(, 7).Address
sum_ifs_case_sensitive = Evaluate("SUMPRODUCT(--(ISNUMBER(FIND(" & Chr(34) & criteria & Chr(34) & "," & criteria_range & ")))," & sum_range & ")")
Worksheets("Total").Cells(Rows.Count, "AF").End(xlUp).Offset(1).Value = sum_ifs_case_sensitive
End With
Next
End With
.Cells(2, 1).ClearContents
End With
.AutoFilterMode = False
End With
End Sub
I have a sheet called Backlog containing rows and columns of data. I need code that will search row by row in the 2nd to last column looking for #N/A. When it finds #N/A it needs to check the last column if it contains a C or not. If it contains a C then the whole row should be appended to a sheet called Logoff. If the last column does not contain a C then the whole row should be appended to a sheet called Denied. The row should be deleted from the original Backlog sheet once moved to either Logoff or Denied. The code I have below is not working. After the first For Statement it goes to End Sub, but there is not any compiling errors.
Private Sub CommandButton2_Click()
Dim IMBacklogSh As Worksheet
Set IMBacklogSh = ThisWorkbook.Worksheets("Backlog")
Dim logoffSh As Worksheet
Set logoffSh = ThisWorkbook.Worksheets("Claims Logged off")
Dim deniedsh As Worksheet
Set deniedsh = ThisWorkbook.Worksheets("Claims Denied")
IMBacklogSh.Select
Dim i As Long
For i = 3 To Cells(Rows.Count, 13).End(xlUp).Row
If Cells(i, 13).Value = "#N/A" Then
If Cells(i, 14).Value = "C" Then
IMBacklogSh.Rows(i).EntireRow.Copy Destination:=logoffSh.Range("A" & logoffsh.Cells(Rows.Count, "A").End(xlUp).Row + 1)
Else
IMBacklogSh.Rows(i).EntireRow.Copy Destination:=deniedsh.Range("A" & deniedsh.Cells(Rows.Count, "A").End(xlUp).Row + 1)
End If
End If
Next i
End Sub
Try it as If Cells(i, 13).Text = "#N/A" Then . #N/A is an error code, not a value; however, the Range.Text property can be examined or the IsError function could be used to examine the cell's contents for any error.
If Cells(i, 13).Text = "#N/A" Then
'Alternate with IsError
'If IsError(Cells(i, 13)) Then
If Cells(i, 14).Value = "C" Then
IMBacklogSh.Rows(i).EntireRow.Copy _
Destination:=logoffSh.Range("A" & logoffsh.Cells(Rows.Count, "A").End(xlUp).Row + 1)
Else
IMBacklogSh.Rows(i).EntireRow.Copy _
Destination:=deniedsh.Range("A" & deniedsh.Cells(Rows.Count, "A").End(xlUp).Row + 1)
End If
End If
However, individual cell examination is not necessary and time consuming. The AutoFilter method can be used to isolate #N/A with C and #N/A with <>C.
Private Sub CommandButton2_Click()
Dim IMBacklogSh As Worksheet, logoffSh As Worksheet, deniedsh As Worksheet
Set IMBacklogSh = ThisWorkbook.Worksheets("Backlog")
Set logoffSh = ThisWorkbook.Worksheets("Claims Logged off")
Set deniedsh = ThisWorkbook.Worksheets("Claims Denied")
With IMBacklogSh
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.AutoFilter field:=13, Criteria1:="#N/A"
.AutoFilter field:=14, Criteria1:="C"
With .Resize(.Rows.Count - 1, Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:= _
logoffSh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'optionally delete the originals
.EntireRow.Delete
End If
End With
.AutoFilter field:=14, Criteria1:="<>C"
With .Resize(.Rows.Count - 1, Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Copy Destination:= _
deniedsh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
'optionally delete the originals
.EntireRow.Delete
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I'm currently using Excel 2010 and am trying to run some code I put together in VBA for Applications (after hitting alt+F11). I typed up the code in a notepad that appeared after double clicking the project I wanted to work on. I also saved everything as Excel Macro Enabled Workbook (*.xlsm).
I am trying to color the backgrounds of Column D either green or red if columns S, T, and U meet the criteria. If the columns all have a value of 0 then Cell D should be colored green. If not, it should be colored red.
Sub GreenOrRed()
Dim i As Integer
For i = 2 To i = 27293
If (Cells(i, "S").Value = 0 And Cells(i, "T").Value = 0 And Cells(i, "U").Value = 0) Then
Cells(i, "D").Interior.ColorIndex = 10
Else
Cells(i, "D").Interior.ColorIndex = 9
End If
Next i
End Sub
The code runs and doesn't throw any error but it also doesn't do anything. What am I doing wrong?
You are using counter in For loop incorrectly. It should be like this...
For i = 2 To 27293
Changed For condition.
Try this:-
Sub GreenOrRed()
Dim i As Integer
For i = 2 To 27293
If (Cells(i, "S").Value = 0 And Cells(i, "T").Value = 0 And Cells(i, "U").Value = 0) Then
Cells(i, "D").Interior.ColorIndex = 10
Else
Cells(i, "D").Interior.ColorIndex = 9
End If
Next i
End Sub
A slightly different approach:
Sub GreenOrRed()
Dim r As Range, rr As Range
Set rr = Range("D1:D27293")
For Each r In rr
If r.Offset(0, 15).Value = 0 And r.Offset(0, 16).Value = 0 And r.Offset(0, 17).Value = 0 Then
r.Interior.ColorIndex = 10
Else
r.Interior.ColorIndex = 9
End If
Next r
End Sub
You might consider setting one (or two) conditional formatting rules.
Option Explicit
Sub GreenOrRed()
With ActiveSheet
With .Range(.Cells(2, "D"), .Cells(.Rows.Count, "D").End(xlUp))
.Interior.ColorIndex = 9
.FormatConditions.Delete
With .FormatConditions.Add(Type:=xlExpression, Formula1:="=and(sum($S2)=0, sum($T2)=0, sum($U2)=0)")
.Interior.ColorIndex = 10
.StopIfTrue = True
End With
End With
End With
End Sub
I've used individual SUM functions to ensure that any text returns a numerical value of zero.
Alternate AutoFilter method.
Sub GreenOrRedFiltered()
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
With .Range(.Cells(1, "D"), .Cells(.Rows.Count, "D").End(xlUp)).Resize(, 18)
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).Columns(1).Interior.ColorIndex = 9
.AutoFilter Field:=16, Criteria1:=0, Operator:=xlOr, Criteria2:=vbNullString
.AutoFilter Field:=17, Criteria1:=0, Operator:=xlOr, Criteria2:=vbNullString
.AutoFilter Field:=18, Criteria1:=0, Operator:=xlOr, Criteria2:=vbNullString
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.Columns(1).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = 10
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I need to remove all rows without leaving any unique record. If duplicate exists delete all matching rows. Criteria is column C if any duplicate record exists in column C then delete entire row (including unique).
Below given code is working but leaving the unique row Even I don't want that.
Code:
Sub DDup()
Sheets("MobileRecords").Activate
With ActiveSheet
Set Rng = Range("A1", Range("C1").End(xlDown))
Rng.RemoveDuplicates Columns:=Array(3, 3), Header:=xlYes
End With
End Sub
I like the code from Jeeped, but it isn't the best readable one. Therefore, here is another solution.
Sub remDup()
Dim rng As Range, dupRng As Range, lastrow As Long, ws As Worksheet
Dim col As Long, offset As Long, found As Boolean
'Disable all the stuff that is slowing down
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Define your worksheet here
Set ws = Worksheets(1)
'Define your column and row offset here
col = 3
offset = 0
'Find first empty row
Set rng = ws.Cells(offset + 1, col)
lastrow = rng.EntireColumn.Find( _
What:="", After:=ws.Cells(offset + 1, col)).Row - 1
'Loop through list
While (rng.Row < lastrow)
Do
Set dupRng = ws.Range(ws.Cells(rng.Row + 1, col), ws.Cells(lastrow, col)).Find( _
What:=rng, LookAt:=xlWhole)
If (Not (dupRng Is Nothing)) Then
dupRng.EntireRow.Delete
lastrow = lastrow - 1
found = True
If (lastrow = rng.Row) Then Exit Do
Else
Exit Do
End If
Loop
Set rng = rng.offset(1, 0)
'Delete current row
If (found) Then
rng.offset(-1, 0).EntireRow.Delete
lastrow = lastrow - 1
End If
found = False
Wend
'Enable stuff again
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
It works with more than one duplicate and you can define an row offset, which defines how much rows you ignore at the beginning of the column.
I like to try these without any declared variables. It is good practise for keeping your cell / worksheet / workbook hierarchy together.
Sub dupeNuke()
With Worksheets("Sheet1") '<~~ you should know what worksheet you are supposed to be on
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
With .FormatConditions
.Delete
.Add Type:=xlExpression, Formula1:="=COUNTIF(C:C, C2)>1"
End With
With .FormatConditions(.FormatConditions.Count)
.Interior.Color = vbRed
End With
End With
With .Resize(.Rows.Count, 1).Offset(0, 2)
.AutoFilter Field:=1, Criteria1:=vbRed, Operator:=xlFilterCellColor
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, Cells)) Then
.EntireRow.Delete
End If
End With
End With
With .Resize(.Rows.Count - 1, 1).Offset(1, 2)
With .FormatConditions
.Delete
End With
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
Obviously, this is heavily reliant on the With ... End With statement. An underrated / underused method in my estimation.
I've been trying to add the entire row that meets the highlight criteria to an array but I've been struggling getting it to work.
The code loops through multiple identifiers and highlight them in red based off of the preconditions. I would like to add the entire row to an array for all rows meeting the precondition criteria.
Sub SWAPS101()
'red color
' If "Security Type" = SW
' If "New Position Ind" = N
' If "Prior Price" = 100
' If "Current Price" does not equal 100
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Object
'Sheets("Output").Activate
With ActiveSheet
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("E2:E" & LastRow) 'new position
If cell = "N" And cell.Offset(, 16) = "SW" And cell.Offset(, 5) = 100 _
And cell.Offset(, 4) <> 100 Then
With cell.EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6382079
.TintAndShade = 0
.PatternTintAndShade = 0
End With
' LastRow = Range("b65000").End(xlUp).Row
' For r = 2 To LastRow
Row = Row + 1
TempArray(Row, 1) = Cells(r, cell))
Next r
End If
Next cell
End With
End Sub
Using the Range.CurrentRegion property to isolate the 'island' of data radiating out from A1 is an easy method to restrict the 'scope' of the operation. You do not want to be copying thousands of blank cells into an array.
Sub SWAPS101()
'red color
' If "Security Type" = SW
' If "New Position Ind" = N
' If "Prior Price" = 100
' If "Current Price" does not equal 100
Dim a As Long, r As Long, c As Long, vVALs As Variant
With Sheets("Output")
'reset the environment
If .AutoFilterMode Then .AutoFilterMode = False
.Columns(5).Interior.Pattern = xlNone
With .Cells(1, 1).CurrentRegion
ReDim vVALs(1 To .Columns.Count, 1 To 1)
.AutoFilter field:=Application.Match("security type", .Rows(1), 0), Criteria1:="SW"
.AutoFilter field:=Application.Match("new position ind", .Rows(1), 0), Criteria1:="N"
.AutoFilter field:=Application.Match("prior price", .Rows(1), 0), Criteria1:=100
.AutoFilter field:=Application.Match("current price", .Rows(1), 0), Criteria1:="<>" & 100
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
'check to ensure that there is something to work with
If CBool(Application.Subtotal(103, .Cells)) Then
With Intersect(.Columns(5), .SpecialCells(xlCellTypeVisible))
.Cells.Interior.Color = vbRed
End With
Debug.Print .SpecialCells(xlCellTypeVisible).Areas.Count
With .SpecialCells(xlCellTypeVisible)
For a = 1 To .Areas.Count
Debug.Print .Areas(a).Rows.Count
For r = 1 To .Areas(a).Rows.Count
Debug.Print .Areas(a).Rows(r).Address(0, 0)
ReDim Preserve vVALs(1 To UBound(vVALs, 1), 1 To UBound(vVALs, 2) + 1)
For c = 1 To .Columns.Count
vVALs(c, UBound(vVALs, 2)) = _
.Areas(a).Rows(r).Cells(1, c).Value
Next c
Next r
Next a
vVALs = Application.Transpose(vVALs)
End With
'array is populated - do something with it
Debug.Print LBound(vVALs, 1) & ":" & UBound(vVALs, 1)
Debug.Print LBound(vVALs, 2) & ":" & UBound(vVALs, 2)
'this dumps the values starting a couple of rows down
With .Cells(.Rows.Count, 1).Offset(3, 0)
.Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
End With
End If
End With
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left a lot of the debug.print statements in so you can watch how the process loops through the rows of each Range.Areas property within the Range.SpecialCells method's xlCellTypeVisible set. Use F8 to step through the code while keeping an eye on the VBE's Immediate window ([Ctrl]+G).
Post-processing results
You can add ranges to an array, such as:
Dim myArray() As Variant 'declare an unallocated array.
myArray = Range("E2:E" & LastRow) 'myArray is now an allocated array, range being your row
My idea is to create union range uRng but I couldn't fill it in array so create temp sheet and past this range in it then fill the selection (the copied range) in array then delete this temp sheet.
this will work but I don't know if it is good way so this is just an idea because Jeeped answer seems the full answer for this question
Sub SWAPS101()
'red color
' If "Security Type" = SW
' If "New Position Ind" = N
' If "Prior Price" = 100
' If "Current Price" does not equal 100
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Range
Dim TempArray As Variant, uRng As Range, tempSH As Worksheet
'Sheets("Output").Activate
With ActiveSheet
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("E2:E" & LastRow) 'new position
If cell = "N" And cell.Offset(, 16) = "SW" And cell.Offset(, 5) = 100 _
And cell.Offset(, 4) <> 100 Then
With cell.EntireRow.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 6382079
.TintAndShade = 0
.PatternTintAndShade = 0
End With
If uRng Is Nothing Then
Set uRng = cell.EntireRow
Else
Set uRng = Union(uRng, cell.EntireRow)
End If
End If
Next cell
End With
If Not uRng Is Nothing Then
Application.ScreenUpdating = False
Set tempSH = Sheets.Add
uRng.Copy
tempSH.Paste
TempArray = Selection.Value
Application.DisplayAlerts = False
tempSH.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End If
End Sub