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.
Related
Sub A()
Dim I, Q, C_Count As Integer
C_Count = Worksheets("0618").Cells.SpecialCells(xlLastCell).Column
For I = 7 To C_Count
Q = Worksheets("0618").Cells(9, I).Value
If 0 < Q And Q < 100 Then
Worksheets("sheet1").Cells(I - 1, 3).Value = Worksheets("0618").Cells(2, I).Value
Worksheets("sheet1").Cells(I - 1, 4).Value = Worksheets("0618").Cells(9, I).Value
Worksheets("sheet1").Cells(I - 1, 5).Value = Worksheets("0618").Cells(4, I).Value
End If
Next
End Sub
The result of the code
I want to delete the empty rows with vba code but don't know how to.
Could someone tell me how to do it?
This is a sample code:
Sub Delete()
Dim LastRow As Long
Dim i As Long
With ThisWorkbook.Worksheets("Sheet1")
'Find the last row of Column A Sheet1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop starting from last row to 1 row
For i = LastRow To 1 Step -1
'Check if the value in column A row i is empty
If .Range("A" & i).Value = "" Then
.Rows(i).EntireRow.Delete
End If
Next i
End With
End Sub
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/
I have a data set that consists of columns A-D. Values in A and D are the same respectively, as are B and C. It is listed for the purposes of A correlating to B, and C to D. What I would like to do is to be able to create a new two column list using the combinations of A&B and C&D. But I need them to go in the order they are originally listed i.e. new sheet, Row 1 A&B, Row 2 C&D, Row 3 A&B etc.
At first I tried simple filters and sorting, but due to the range of the data set at times, it makes the values that need to be close too each other too far. I tried a few failed splices and cuts. I had hoped there would just be a built in excel function.
Option Explicit
Sub combineList()
Dim i As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If Cells(i, 1) = "" Then
'do nothing
Else
If Cells(i, 9) = "" Then
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
Else
i = i + 1
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
'i = i - 1
End If
End If
Next i
End With
End Sub
First attempt, trying to get it to skip over rows for C&D.
Sub newMethod()
Dim i As Long
Dim j As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("a" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow Step -1
If Cells(i, 1) = "" Then
'do nothing
Else
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
'i = i + 1
End If
Next i
For j = 2 To lRow Step 2
If Cells(j, 1) = "" Then
'do nothing
Else
Cells(j + 1, 9) = Cells(j, 4)
Cells(j + 1, 10) = Cells(j, 5)
'j = j + 1
End If
Next j
End With
End Sub
As stated above, to be able to reorganize the list by "shuffling" it together. Basically each row split into two. My attempts have ended with loops that just constantly overwrite themselves.
You can obtain your desired results using formulas.
It is a matter of deriving the mathematics of obtaining the correct row/col numbers in sequence.
F2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+1)
G2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+2)
can someone help me with that? In column C, individual cells are initially empty, and the code works in the section. In the sections where there are several empty cells in column C, the code does not work. What exactly do I have to change regarding "lastrow2" or at an other position of the code to achieve the desired goal?
lastrow2 = Cells(Cells.Rows.Count, "C").End(xlUp).Row
For j = lastrow2 To 1 Step -1
If (Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0) Then
Rows(j).Delete
End If
Next j
Would be very grateful for your support. :)
Best regards,
Bamane
Testing column C may be too shallow. This:
Sub trewq()
ActiveSheet.UsedRange
Set r = ActiveSheet.UsedRange
lastrow2 = r.Rows.Count + r.Row - 1
For j = lastrow2 To 1 Step -1
If (Cells(j, 4) = 0 And Cells(j, 5) = 0 And Cells(j, 6) = 0 And Cells(j, 7) = 0 And Cells(j, 8) = 0 And Cells(j, 9) = 0) Then
Rows(j).Delete
End If
Next j
End Sub
may be better..................we are checking columns D through I
Instead of checking that each cell = 0, why not use a couple of formulas?
Sub DeleteRowsWithZero()
Dim lastrow As Long
lastrow = Cells(Cells.Rows.Count, "C").End(xlUp).Row
Dim j As Long
For j = lastrow To 1 Step -1
If WorksheetFunction.Sum(Range("D" & j & ":I" & j)) = 0 And _
WorksheetFunction.CountIf(Range("D" & j & ":I" & j), "*") = 0 Then
Rows(j).Delete
End If
Next
End Sub
WorksheetFunction.Sum() checks that all the cells in your test range have a value of 0.
But if some of those cells have a text value rather than a numeric value, you'll still get 0, so we then use WorksheetFunction.CountIf() to test that none of those cells contain text (by checking against the wildcard "*").
If both checks = 0, then we can delete the row.
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