I am trying to change the cells under B column to blue if the sum for the corresponding row is less than 55000. Below is my code I have figured out to achieve that for one row. How could I modify it so that it works for the other rows if I have a lot of rows?
Dim rng As Range
Dim result As Long
Set rng = Sheets(2).Range("C2:N2")
result = Application.WorksheetFunction.Sum(rng)
If result < 550000 Then
Sheet2.Range("B2").Font.Color = vbBlue
Sheet2.Range("B2").Font.Bold = True
End If
With a loop:
With Sheet2
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
Dim i As Long
For i = 2 To lastRow
If Application.Sum(.Range("C" & i & ":N" & i)) < 550000 Then
.Cells(i, "B").Font.Color = vbBlue
.Cells(i, "B").Font.Bold = True
End If
Next
End With
EDIT:
If you want to do the same thing, but for columns instead of rows:
With Sheet2
Dim lastColumn As Long
lastColumn = .Cells(1, .Columns.Count).End(xlToRight).Column
For i = 3 To lastColumn
If Application.Sum(.Columns(i)) < 550000 Then
.Cells(1, i).Font.Color = vbBlue
.Cells(1, i).Font.Bold = True
End If
Next
End With
Related
In column A1:A145 need code to highlight color.
Apply format color in A1, how many rows? Base on the image1.
enter image description here
In column A , 14 rows will have yellow, next 14 rows will have blue and so on. (number will always change)
In column B need to repeat the number that appear in column D.
Looking for this result image 2
enter image description here
The below code only copy the color and number from column C at the end of row A:145, what we need is trying to highlight rows base on another cell value, working with sheet 1 until sheet 8 or more sheets.
Sub Color_My_Cells()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To Lastrowa
Cells(Lastrow, 1).Resize(Cells(i, 2).Value) = Cells(i, 2).Value
Cells(Lastrow, 1).Resize(Cells(i, 2)).Interior.Color = Cells(i, 2).Interior.Color
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row + 1
Next
Application.ScreenUpdating = True
End Sub
#GoalExcel the code below loops through all sheets in your Excel file and repeat the same steps for each one.
Sub ColorMyCells()
Dim i, j, intRowCounterAB, intRowC As Integer
For Each ws In ThisWorkbook.Sheets
ws.Activate
intRowC = Evaluate("=COUNTA(C:C)")
intRowCounterAB = 1
For i = 1 To intRowC
For j = 0 To Range("C" & i).Value - 1
Range("A" & intRowCounterAB).Interior.Color = Range("C" & i).Interior.Color
Range("B" & intRowCounterAB).Value = Range("D" & i).Value
intRowCounterAB = intRowCounterAB + 1
Next j
Next i
Next ws
End Sub
please help i want to sort the name column such that each name starts after every blank cell.
I want it look something like this..pls help it's a pretty long column
Option Explicit
Sub SetNamePosition()
Dim arr As Variant
Dim i As Long: i = 1 ' for Loop
Dim j As Long: j = 1 ' for Array
Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim rngColB As Range: Set rngColB = Range("B2:B" & lastRow)
Dim rngNames As Range: Set rngNames = Range("C1") ' Temporary range
' Get column B names only
rngColB.SpecialCells(xlCellTypeConstants, 2).Copy
rngNames.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Set rngNames = Range(rngNames, rngNames.End(xlDown))
' Load rngNames to array
arr = Application.Transpose(rngNames)
' Clear rng of column B and rngNames
rngColB.Clear
rngNames.Clear
' Insert names
For i = 2 To lastRow
' set name
Cells(i, 1).Offset(0, 1).Value = arr(j)
' find next cell
i = Cells(i, 1).End(xlDown).Row + 1
j = j + 1
Next i
End Sub
I's probably better to remove the empty ranges before making the array, but here's one way to distribute the names:
Loading the range ito an array, then go through the numbers and look for empty ranges.
This assumes that we are working with column "A" and "B" (1 and 2), starting at the top.
Sub test()
Dim arr As Variant
Dim lastRow As Long, i As Long, j As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
arr = Application.Transpose(Range("B2:B" & lastRow))
Range("B2:B" & lastRow).Clear
j = 1
For i = 2 To lastRow
Cells(i, 2) = arr(j)
j = j + 1
If j >= UBound(arr) Then Exit For
While arr(j) = "" And j < UBound(arr)
j = j + 1
Wend
While Not Cells(i, 1).Value = ""
i = i + 1
Wend
Next i
End Sub
Any leftover names will be removed
Dim rng2 As Range:
Set rng2 = ActiveSheet.Range("D:E", ActiveSheet.Cells.End(xlUp))
With rng2
.HorizontalAlignment = xlLeft
.Borders.LineStyle = xlContinous
End With
I understand my code like this.
rng2 is assigned to the Range "D:E" on the ActiveSheet. All Cells count to rng2 as long no blank cell occurs (End(xlUp))
With rng2 i assign to my Range rng2 the above mentioned settings which are left arrangement which works and Borders which shall in a continously Syle frame my rng2 - this does not work
I have to say that the first cell of D:E includes a value in D1 (header) but not in E1 (no header) is this the problem?
EDIT 17.05.21 full code
Sub Duplicate()
Dim nA As Long, nD As Long, i As Long, rc As Long
Dim s As String, j As Long
Range("A:A").Copy Range("D1")
Range("B1").Copy Range("E1")
Range("D:D").RemoveDuplicates Columns:=1, Header:=xlYes
rc = Rows.Count
nA = Cells(rc, 2).End(xlUp).Row
nD = Cells(rc, 4).End(xlUp).Row
For i = 2 To nD
v = Cells(i, 4)
V2 = ""
For j = 2 To nA
If v = Cells(j, 1) Then
V2 = V2 & Cells(j, 2) & ","
End If
Next j
Cells(i, 5) = Mid(V2, 1)
Next i
'neu
Dim rng2 As Range
Dim lastrow As Long
lastrow = ActiveSheet.UsedRange.Rows.Count
Set rng2 = ActiveSheet.Range("D1", "E" & lastrow)
With rng2
.HorizontalAlignment = xlLeft
.Borders.LineStyle = xlContinuous
End With
Debug.Print
End Sub
A better approach should be like this:
Dim rng2 As Range
dim lastrow as long
lastrow = ActiveSheet.UsedRange.Rows.Count
Set rng2 = ActiveSheet.Range("D1", "E" & lastrow)
With rng2
.HorizontalAlignment = xlLeft
.Borders.LineStyle = xlContinuous
End With
In additional, there is a typo on your code,
xlContinous should be xlContinuous
Continue to sort your row for the border issue. Assuming you have 2 col with difference row value. Col F has 8 rows, while Col H has 5 rows:
In order to obtain lastrow for different row, you can use the code as following:
Sub t()
Dim lastrowCola As Long
Dim lastrowColb As Long
lastrowCola = Sheet1.Range("F1").End(xlDown).Row
Debug.Print lastrowCola
lastrowColb = Sheet1.Range("H1").End(xlDown).Row
Debug.Print lastrowColb
End Sub
So debug.print for lastrowCola is 8, while lastrowColb is 5. Based on your scenario, you can adjust accordingly.
I trying to write a code where I want to look select range from Start to End in column A then fill the selected range in Column B with '1'. But my code only fill up bottom parts and missed out top parts. Refer to this photo. How do i make sure it go through every row and when it encounter Start, it will look for nearest End and fill up column B?
Sub Select()
Dim LastRowA As Long, i As Long
Dim findrow As Long, findrow2 As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
findrow = Range("A:A").Find("Start", Range("A1")).Row
findrow2 = Range("A:A").Find("End", Range("A" & findrow)).Row
Range("A" & findrow & ":A" & findrow2).Offset(0, 1).Value = "1"
Next i
End With
End Sub
This will find Start, loop through until it finds End. Tested and working as requested.
Sub Select()
Dim LastRowA, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
If .Cells(i, 1) = "Start" Then
Do Until .Cells(i, 1) = "End"
.Cells(i, 2).Value = 1
i = i + 1
Loop
.Cells(i, 2).Value = 1
End If
Next i
End With
End Sub
Find is a precarious beast to use in VBA. It would be far simpler to just loop through the cells, keeping track of whether or not you're between Start and End:
Sub Select()
Dim LastRowA As Long, i As Long, b As Boolean
With ThisWorkbook.Worksheets("Sheet1")
LastRowA = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRowA
If .Cells(i, 1).Value = "Start" Then
b = True
.Cells(i, 2).Value = 1
ElseIf .Cells(i, 1).Value = "End" Then
b = False
.Cells(i, 2).Value = 1
ElseIf b Then
.Cells(i, 2).Value = 1
End If
Next i
End With
End Sub
I'm putting together a list generator and I'm having trouble getting my code to work properly (again!).
The code works for the first row of data but ignores all the others.
All the codes are the same, I've got 5 buttons. The Level # is stored in column X, so #24.
I want to be able to click the button and generate a list of the rows that contain the Level #, from the PI sheet to the Lists sheet.
The data that will be transferred is contact info and sizing info and is in the same row as the Level #.
Private Sub CommandButton2_Click() 'level 1 button
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "1" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Level5_Click()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "5" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Lvl2_Click()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "2" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Lvl3_Click()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "3" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub
Private Sub Lvl4_Click()
Dim LastRow As Long
Dim i As Long, j As Long
'Find the last used row in a Column: column A in this example
With Worksheets("PI")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'first row number where you need to paste values in Sheet1'
With Worksheets("Lists")
j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
End With
For i = 1 To LastRow
With Worksheets("PI")
If .Cells(i, 24).Value = "4" Then
.Rows(i).Copy Destination:=Worksheets("Lists").Range("A" & j)
j = j + 1
End If
End With
Next i
End Sub