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
Related
I have a task to preform and I'm half way through.
I need a loop to iterate every value on, let's say, 'A' (A1, A2, A3, etc) column and then acquire all the cell values from 'B' (B1, B2, B3, etc) column for the first cell on 'A' and them move to acquire all the values from 'C' column for the second cell on 'A' (A2), and so on.
I manage to accomplish to loop every cell on 'A' until blank and acquire all the values from 'B' until blank in 'A' column, but not to change to 'C' column when the cell on 'A' change to the second (A2).
Dim BlankFound As Boolean
Dim BlankFound_1 As Boolean
Dim x As Long
Dim y As Long
Do While BlankFound = False
x = x + 1
If Worksheets("shee1").Cells(x, "A").Value = "" Then
BlankFound = True
ElseIf Worksheets("shee1").Cells(x, "A").Value = "title" Then
Else
value_1 = Worksheets("shee1").Cells(x, "A").Value
BlankFound_1 = False
y = 0
Do While BlankFound_1 = False
y = y + 1
If Worksheets("sheet2").Cells(y, "A").Value = "" Then
BlankFound_1 = True
ElseIf Worksheets("sheet2").Cells(y, "A").Value = "values" Then
Else
value_2 = Worksheets("sheet2").Cells(y, "A").Value
End If
Loop
End If
'End If 'this End If doesn't have an If
Loop
If I understood your intentions I think this will do:
Option Explicit
Sub consolidate()
Dim x As Long
Dim i As Long
Dim Col As Long
With ThisWorkbook.Sheets("MySheet") 'Change MySheet for your working sheet name
Col = .Cells(1, .Columns.Count).End(xlToLeft).Column 'calculate the last column
'instead looping for every cell, just use the Sum function for the range in every column
For i = 2 To Col
.Cells(i, 1) = Application.Sum(.Columns(i)) 'the i will increase both the column to calculate and the row for the output
Next i
End With
End Sub
I have two columns A and B, If A Column have the specific value for Eg: High then the corresponding B Column should contain the Date value.
If A Column have the specific value for Eg: High and the corresponding B Column does not have date value then the cell should be highlighted as Red.
Sub ColorColB()
Dim sht As Worksheet
Dim LastRow, i As Long
Set sht = ActiveSheet
Find the last cell in column A... counts how many rows
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Run a loop.. checking if there is nothing in column B then color it red
For i = 1 to LastRow
If cells(i, 2) = "" then Range("B" & i).Interior.Color = RGB(255, 0, 0)
Next i
End sub
I've a data set that looks similar to the below.
I'd like to average the data in the rightmost column only.
My range starts at C4 with no set end to either rows or columns.
**1**
1 **2**
1 2 **3**
1 **2**
**1**
I've put the following together which does what I need it to do for a single fixed column but I don't know how to expand that out to always use the value from the right most column.
Dim Sum, Count As Integer
Count = 0
Sum = 0
Application.ScreenUpdating = False
Range("C4").Select
Do While ActiveCell.Value <> ""
Sum = Sum + ActiveCell.Value
Count = Count + 1
ActiveCell.Offset(1, 0).Activate
Loop
Range("O1").Value = Sum / Count
Thank you.
This will cycle the rows.
The MATCH will return the column number of the last column with a number in it.
Then we get the number on that row in that column and add it to an array.
Then after the loop we average the array.
Sub aver()
With Worksheets("Sheet4") 'Change to your sheet
Dim lastrw As Long
lastrw = .Cells(.Rows.Count, 3).End(xlUp).Row
Dim num() As Variant
ReDim num(1 To lastrw) As Variant
Dim i As Long
For i = 4 To lastrw
Dim j As Long
j = Application.Match(1E+99, Rows(i), 1)
num(i) = .Cells(i, j).Value
Next i
.Range("O1").Value = Application.Average(num)
End With
End Sub
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 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