Objective of the code is to count the number of rows that meet three conditions and output the count to populate in a particular cell.
Input data:
The 3 conditions are:
Column A of the row must contain a date field
Column B of the row must be equal to "B"
Column A of the row must have red font
I have the following code, but it seems to not pick up the last condition properly. I am expecting to see 1 as an output but seeing 0:
Sub code()
Dim lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Cells(2, "D").Value = "Count"
Count = 0
For i = 2 To lrow
If IsDate(Cells(i, "A").Value) = True And Cells(i, "B").Value = "B" And Cells(i, "A").Font.Color = -16776961 Then
Count = Count + 1
End If
Next i
Cells(2, "E").Value = Count
End Sub
Sub test1()
Set cl = ActiveSheet.Range("A2")
Do Until IsEmpty(cl)
cnt = cnt - (IsDate(cl.Value) And cl.Offset(0, 1) = "B" And cl.Font.Color = vbRed)
Set cl = cl.Offset(1)
Loop
Debug.Print "Matches = " & cnt
End Sub
Input:
Output:
Matches = 2
Try this:
Dim lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Cells(2, "D").Value = "Count"
Count = 0
For i = 2 To lrow
If IsDate(Cells(i, "A").Value) = True And Cells(i, "B").Value = "B" And Cells(i, "A").Font.Color = vbRed Then
Count = Count + 1
End If
Next i
Cells(2, "E").Value = Count
You can achieve this using the color index as below:
.Font.ColorIndex = 3 which is red [enter link description here][1] They give more options and details on working with font colors.
Sub code()
Dim lrow As Long
lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Cells(2, "D").Value = "Count"
Count = 0
For i = 2 To lrow
If IsDate(Cells(i, "A").Value) = True And Cells(i, "B").Value = "B" And Cells(i, "A").Font.ColorIndex = 3 Then
Count = Count + 1
End If
Next i
Cells(2, "E").Value = Count
End Sub
[1]: https://access-excel.tips/excel-vba-color-code-list/
Related
Sub Formatted_Salary()
Dim lastrow, Total As Integer
lastrow = 0
Total = 0
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If Cells(i, 1) = "" Then
ActiveSheet.Rows(i).EntireRow.Delete
ElseIf Cells(i, 11).Value Then
Total = Total + Cell.Value (Problem Area)
End If
Next
newlastrow = Cells(Rows.Count, 1).End(xlUp).Row
Cells(newlastrow + 1, 10).Value = "Total Base Salary"
Cells(newlastrow + 1, 11).Value = Total
Cells(newlastrow + 1, 11).Font.Color = vbGreen
End Sub
The line of code label as problem area is not working, and I would like some help. (im new to all is this). Basically what I would like the code to do is to delete all the blank rows and then add the total value of a column K and the print value at desired location. Thanks. Any help is appreciated.
The VBA code below calculates the Sum of cells above empty cells in a column in Excel. The number of rows preceding each empty cell in the column is in not the same. I want to adjust the code to calculate the average instead. A counter can be added and then divide the sum (which is already calculated) by the counter.
The original problem and the code (written by Bernard Liengme) are presented on the link below:
https://answers.microsoft.com/en-us/msoffice/forum/all/automatically-calculate-the-sum-of-data-separated/a691afcf-683e-463f-bad7-9fa3a81cf48c
Thanks.
Sub tryme()
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To lastRow
If Cells(k, "A") <> "" Then
Subtotal = Subtotal + Cells(k, "B")
Else
Cells(k, "B") = Subtotal
Subtotal = 0
End If
Next k
Cells(lastRow + 1, "B") = Subtotal
End Sub
Add Subaverages
A Quick Fix
Option Explicit
Sub AddSubAVG()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve
Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim k As Long
Dim tCount As Long
Dim tSum As Double
For k = 1 To LastRow
If ws.Cells(k, "A").Value <> "" Then
tSum = tSum + ws.Cells(k, "B").Value
tCount = tCount + 1
Else
If tCount > 0 Then
ws.Cells(k, "B").Value = tSum / tCount
tSum = 0
tCount = 0
End If
End If
Next k
If tCount > 0 Then ws.Cells(LastRow + 1, "B").Value = tSum / tCount
End Sub
I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub
enter image description hereThere are 2 sheets, Sheet1 and Sheet2.
Sheet1 contain 10 columns and 5 rows with data including blank.
The requirement is to copy the data from Sheet 1 and to put in another sheet Sheet 2, wherein only populate the cell which is not blank.
I get the run time error 1004 - Application or object defined error.
The code snippet is:-
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> " " Then
Range(Cells(i, 2), Cells(i, 2)).Copy
Worksheets("Sheet2").Select
wsht2.Range(Cells(1, i)).PasteSpecial Paste:=xlPasteFormats
End If
Next i
Can u help me in sorting this out?
You cannot define a range like that:
wsht2.Range(Cells(1, i))
you might use:
wsht2.Cells(1, i).PasteSpecial Paste:=xlPasteFormats
BTW: with this code you won't find empty cells:
If wsht1.Cells(i, 1).Value <> " " Then
you should use:
If wsht1.Cells(i, 1).Value <> "" Then
(the difference is a missing space between the quotes)
if you want to copy the values only and to make it with a loop I'd do the following:
Sub copying()
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> "" Then
For j = 1 To 5
wsht2.Cells(i, j).Value = wsht1.Cells(i, j).Value
Next j
End If
Next i
End Sub
If you only have 5 cells with data in Sheet 1 and only want those 5 rows copying to Sheet 2 use the following, similar to Shai's answer above with an extra counter for the rows in Sheet 2.
Sub copying()
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
k = 1
For i = 1 To finalrow
If wsht1.Cells(i, 1).Value <> "" Then
For j = 1 To 5
wsht2.Cells(k, j).Value = wsht1.Cells(i, j).Value
Next j
k = k + 1
End If
Next i
End Sub
EDIT
As per your comment if you want to dynamically change j replace For j = 1 To 5 with
For j = 1 To wsht1.Cells(i, Columns.Count).End(xlToLeft).Column
The code below will copy only values in Column A (non-empty cells) from Sheet 1 to Sheet2:
Dim j As Long
Set wsht1 = ThisWorkbook.Worksheets("Sheet1")
Set wsht2 = Sheets("Sheet2")
finalrow = wsht1.Cells(wsht1.Rows.Count, 1).End(xlUp).Row
j = 1
For i = 1 To finalrow
With wsht1
' if you compare to empty string, you need to remove the space inside the quotes
If .Cells(i, 1).Value <> "" And .Cells(i, 1).Value <> " " Then
.Cells(i, 1).Copy ' since you are copying a single cell, there's no need to use a Range
wsht2.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Paste:=xlPasteFormats
j = j + 1
End If
End With
Next i
i have to sort data from sheet1 to sheet2 with reference to non-empty cell in column A. and
i have written code for it as below:
Sub polo()
Dim lastrow As Long
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = Sheets("Sheet1").Cells(i - 1, 2).Value
j = j + 1
End If
Next i
End Sub
But the problem is, i am getting result as in column D of sheet2.
I want result as shown in column E.
Please help.
Try this version:
Sub polo()
Dim lastrow As Long
Dim sTemp as String
lastrow = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
j = 2
For i = 1 To lastrow
If Sheets("Sheet1").Cells(i, 1).Value = "" Then
Sheets("Sheet2").Cells(j, 2).Value = Sheets("Sheet1").Cells(i, 1).Offset(, 1).Value
Sheets("Sheet2").Cells(j, 4).Value = stemp
j = j + 1
Else
stemp = Sheets("Sheet1").Cells(i, 2).Value
End If
Next i
End Sub