I have a worksheet with various data in C5 to H?. The H length will vary on different worksheets but will be greater than 2,000 depending on the worksheet.
So, I need a VBA macro that will check the value in every cell in the H column and if there is a value greater than zero, highlight that row from the C column to the L column.
How about:
Sub ColorMeElmo()
Dim N As Long, i As Long
N = Cells(Rows.Count, "H").End(xlUp).Row
For i = 1 To N
v = Cells(i, "H").Value
If v > 0 Then
Range("C" & i & ":L" & i).Interior.ColorIndex = 27
End If
Next i
End Sub
Related
I have a sheet where the first two columns have row and column addresses and the third column has integer values.
I would like to extract the highest value and it's corresponding address from columns 1 and 2 into a separate list on the sheet.
There may be multiple equal highest values in the third column. How do I get all of those into my list.
I'm a fairly new at Excel VBA.
This could be a start.
Sub maxIntAndOtherStuff()
Dim rng As Range, c As Range, i As Integer, x As Long, y As Long
rw = 1: cl = 3 'Apply starting row & column
Set rng = Range(Cells(rw, cl), Cells(Rows.Count, cl).End(xlUp))
For Each c In rng
If c.Value >= i Then
i = c.Value
End If
Next c
y = 9 'Apply column number for output
x = Cells(Rows.Count, y).End(xlUp).Offset(1).Row 'Finds the first empty row in that column
For Each c In rng
If c = i Then
Cells(x, y).Resize(, 3).Value = c.Offset(, -2).Resize(, 3).Value
x = x + 1
End If
Next c
End Sub
I am trying to erase duplicate rows starting from bottom, but it isnt working. It keeps two copies but deletes other duplicate items.
With wb_DST.Sheets(sWs_DST)
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
wb_DST.Sheets(sWs_DST).Range(("A13:A" & lncheckduplicatescolumn - 2 & ":" & "AW13:AW" & lncheckduplicatescolumn - 2)).Sort key1:=wb_DST.Sheets(sWs_DST).Range("A13:A" & lncheckduplicatescolumn - 2), order1:=xlDescending, Header:=xlNo
Dim row As Range
Dim rng As Range
Dim cell As Range
Dim i As Integer
Set rng = wb_DST.Sheets(sWs_DST).Range("A13:A" & lncheckduplicatescolumn - 2)
For Each cell In rng
If cell.Value = cell.Offset(-1, 0).Value Then
.cell.Offset(-1, 0).EntireRow.Delete
End If
Next
End with
If Excel shows
Column A Column B
A 1
A 2
A 3
I want the code to retain the last row, and delete the ones above it.
The result should be
Column A Column B
A 3
Thanks,
Work from the bottom up and loop until all 'higher' (i.e. in a row less than current) are removed.
dim dup as variant, r as long, lncheckduplicatescolumn as long
With wb_DST.Sheets(sWs_DST)
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
for r = lncheckduplicatescolumn to 2 step -1
dup = application.match(.cells(r, "A").value, .columns(1), 0)
if dup < r then .rows(dup).delete
next r
end with
This will take a few more cycles than is absolutely necessary but the operation is efficient enough that it should not make a significant difference.
Dim x as integer
Dim y as string
Dim J as integer
Dim I as integer
x = activesheet.range("A" & Activesheet.range("A1").endxl.down).count 'This will count the total number of rows.
for i = x to 2 'this should count backwards from bottom to top, since you have headers, stop at row 2
y = Activesheet.range("A" & i).value 'places value in a variable
For j = x - i - 1 to 1 'this is another loop, but it should start above the whatever the cell that Y got its value
if activesheet.range("a" & j).value = y then 'comparison
'do what you need to delete the row
end if
Next
Next
I think this will go start at the bottom, put that first value in a variable, and then will go through the rest of the list check the values to see if is compatible. The second for loop might need to be adjusted.
not a pretty answer - but from what it looks like, you should be ending up with the last and first occurrence of the duplicate:
Column A Column B
A 1
A 3
To patch your answer (there are more elegant ways), you could find the last row again after the loop is finished and check for one last duplicate:
For Each cell In rng
If cell.Value = cell.Offset(-1, 0).Value Then
.cell.Offset(-1, 0).EntireRow.Delete
End If
Next
redefine your last row
lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
and check for one more duplicate
If Range("A" & lncheckduplicatescolumn).Value = Range("A" & lncheckduplicatescolumn).Offset(-1, 0).Value Then
.cell.Offset(-1, 0).EntireRow.Delete
End If
I'm very new to Excel VBA so please be good to me :)
My problem is I want to copy values of Column A until the last cell with value and paste it to B C D respectively
Example
Column A has 3 Rows with values Tim,john,Mer respectively
I want to paste it to Columns B2 C2 D2 respectively too
Problem: Column A has a dynamic number of row so I want it to copy until the last notempty cell. but when column A is more than 3 (number of columns to paste) it will loop and paste it to B3 then C3 then D3 and so on until all non empty cell is distributed evenly to the 3 columns(B,C, and D)
Hope this problem is clear
Sub CopyData()
Dim x As Long, i As Long
Application.ScreenUpdating = False
For i = 1 To 100 Step 3
x = x + 1
Range("A" & i & ":A" & i + 2).Copy
Range("B" & x).PasteSpecial xlPasteValues, , , True
Next i
Application.ScreenUpdating = True
End Sub
Maybe make use of the TRANSPOSE function?
Sub TransposeToColumns()
Dim lLastRow As Long
With ThisWorkbook.Worksheets("Sheet1")
'Get the last row (same as going to end of sheet and pressing Ctrl+Up).
lLastRow = .Range("A" & Rows.Count).End(xlUp).Row
If lLastRow > 3 Then
'Cells(1,2) is row 1, column 2.
With .Range(.Cells(1, 2), .Cells(1, lLastRow + 1))
'R1C1 style of referencing - absolute reference to A1 is R1C1 (row 1 column 1).
.FormulaArray = "=TRANSPOSE(R1C1:R" & lLastRow & "C1)"
'Replace formula with values.
.Value = .Value
End With
End If
End With
End Sub
Just realised - this will error out if you try and do it with more than 16383 rows (i.e. the number of columns -1). But it will do all columns in 0.040469668631069 seconds. :)
I have fours lists in Excel of arbitraty lenght.
A B C D
A1 B1 C1 D1
A2 B2 C2 D2
A3 B3 D3
A4 D4
D5
I want to create one table that has every combination from the lists as rows.
A B C D
A1 B1 C1 D1
A1 B1 C1 D2
...
A4 B3 C2 D5
Is there any simple way to do this in Excel - using Excel functionality, formulas or VBA?
If you have your four lists next to each other, highlight the data and insert a pivot table.
Add each of the columns to the "rows" section of the pivot table.
Right-click on each field in turn and click on "Field Settings".
Set the Layout and print to show tabular form, repeated item labels and items with no data as follows.
And this is the resulting table.
I suspect you'll want to delete the rows which contain 1 or more (blank) rows.
This is probably easiest by adding a formula to column E along the lines of
=IF(A2="(blank)",1,0)
Repeat this for the other columns, Add them up and sort by the total.
Delete all rows that have a non-zero entry.
Some nested for statements should handle this problem. Just put this in the VBA for your project and it will create a macro called CreateTable() which should put the table in a new worksheet for you.
Sub CreateTable()
'Creates a table will all combinations of values from four columns
Dim a, b, c, d As Range
'Activates sheet that has data on it to be copied to table
Worksheets("Sheet1").Activate 'Change Sheet1 to the name of your sheet
'Change A2 to first cell of data you want to be copied over
Set a = Range("A2", Range("A2").End(xlDown))
Set b = Range("B2", Range("B2").End(xlDown))
Set c = Range("C2", Range("C2").End(xlDown))
Set d = Range("D2", Range("D2").End(xlDown))
Dim i As Integer
i = 1 'Row number of the first row of data for the table of combinations
Worksheets("Sheet2").Activate 'Change Sheet2 to name of sheet you want the table to be put on
For Each cellA In a.Cells
For Each cellB In b.Cells
For Each cellC In c.Cells
For Each cellD In d.Cells
Worksheets("Sheet2").Cells(i, 1) = cellA.Value
Worksheets("Sheet2").Cells(i, 2) = cellB.Value
Worksheets("Sheet2").Cells(i, 3) = cellC.Value
Worksheets("Sheet2").Cells(i, 4) = cellD.Value
i = i + 1
Next cellD
Next cellC
Next cellB
Next cellA
End Sub
You should show what you've tried already and give specifics of where your data is coming from, but here's a VBA solution. Loops through each item in a given column, for as many rows as there are total combinations of items.
Sub Combination_Table()
Dim rList1 As Range
Dim rList2 As Range
Dim rList3 As Range
Dim rList4 As Range
Dim lLength1 As Long
Dim lLength2 As Long
Dim lLength3 As Long
Dim lLength4 As Long
Dim lRowcounter As Long
Sheets(1).Activate
With Sheets(1)
lLength1 = .Range("A" & .Rows.Count).End(xlUp).Row - 1
lLength2 = .Range("B" & .Rows.Count).End(xlUp).Row - 1
lLength3 = .Range("C" & .Rows.Count).End(xlUp).Row - 1
lLength4 = .Range("D" & .Rows.Count).End(xlUp).Row - 1
Set rList1 = .Range("A2:A" & lLength1)
Set rList2 = .Range("B2:B" & lLength2)
Set rList3 = .Range("C2:C" & lLength3)
Set rList4 = .Range("D2:D" & lLength4)
End With
'The above marks the ranges containing the original un-combined lists,
'with no duplicates and assuming row 1 is the header and all data is on
'columns A-D, without blanks.
rowcounter = 0
Sheets(2).Activate
For i = 1 To lLength1
For j = 1 To lLength2
For k = 1 To lLength3
For l = 1 To lLength4
rowcounter = rowcounter + 1
Sheets(2).Range("A" & rowcounter).Formula = rList1(i, 1).Text
Sheets(2).Range("B" & rowcounter).Formula = rList2(j, 1).Text
Sheets(2).Range("C" & rowcounter).Formula = rList3(k, 1).Text
Sheets(2).Range("D" & rowcounter).Formula = rList4(l, 1).Text
'This changes the text in columns A-D for the given rowcount, to the current
'iteration of the current looped value from the above lists
Next l
Next k
Next j
Next i
End Sub
This Works too and this is simpler.
Sub t()
Dim sht As Worksheet
Dim LastRow As Long, lastcol As Long
Dim i As Integer, j As Integer, k As Integer
Set sht = ThisWorkbook.Sheets("Sheet1")
LastRow = sht.Range("A1").CurrentRegion.Rows.Count
lastcol = sht.Range("A1").CurrentRegion.Columns.Count
k = 0
For i = 2 To LastRow
j = 1
k = k + 1
For j = 1 To lastcol
sht.Cells(i, j).Value = sht.Cells(1, j) & k
Next
Next
End Sub
I have a column, which will contain a few rows of data, and then a blank cell.
I need a way to count the rows upwards in a column until a blank cell and sum the number using VBA. Any ideas?
I'm not 100% sure what you are asking. You say "sum the number" but do not specify if the number you want to sum is the number of rows counted or if you want to sum the value of the cells found.
-Edit-
Give this a try:
This will start at the bottom row and count upward until it finds a blank cell
Once a blank cell is found it will sum the cells between the last blank cell and the current blank cell.
-Edit2-
Added insert to the row under column headers so the first row also gets summed.
Sub CountUp()
Dim TotalRows As Long
Dim TotalCols As Long
Dim Col As Long
Dim i As Long
Dim n As Long
Rows(2).Insert Shift:=xlDown
TotalRows = ActiveSheet.UsedRange.Rows.Count
TotalCols = ActiveSheet.UsedRange.Columns.Count
'Assumes Data you want to sum is in the first column
Col = 1
Cells(TotalRows, Col).Select
For i = TotalRows To 1 Step -1
If Cells(i, Col).Value <> "" Then
n = n + 1
Else
Cells(i, Col).Formula = "=SUM(" & Cells(i + 1, Col).Address(False, False) & ":" & Cells(i + n, Col).Address(False, False) & ")"
n = 0
End If
Next
End Sub
Assuming Column F as the Column and it has number. Try the below code.
Sub sumAndcount()
Dim recCount As Long
Dim recSum As Long
Range("A65000").Value = "=COUNT(F:F)"
recCount = Range("A65000").Value
Range("A65000").Value = "=SUM(F:F)"
recCount = Range("A65000").Value
End Sub