I want to calculate mode for a range.
Range is a variable based on a condition.
Value 1 Value 2 Output
A 10 10
A 12 10
A 10 10
B 5 3
B 3 3
B 2 3
B 3 3
Like in the above case:
I need to calculate the mode(column C), with the range of value 2(column B), with a condition that Value 1(column A)is same in the range.
Sub mode()
Dim count
Dim rng As Range
x = 2
Do While Range("A" & x).Value = Range("A" & x + 1).Value
x = x + 1
Loop
Set rng = Range(Cells(x, 2), Cells(x + 1, 2))
md = WorksheetFunction.mode(rng)
Range("C" & x).Value = md
End Sub
Do You have any clue for that?
If your data are in A1:B7, then put this in C1 and copy down.
It's an array formula so needs to be confirmed with Ctrl, Shift and Enter, and curly brackets will appear round the formula.
=MODE(IF($A$1:$A$7=A1,$B$1:$B$7))
Of course, you could add the formula using VBA.
Enter the following formula as array formula (Ctrl+Shift+Enter) in cell C1 and pull it down
=MODE(IF(A:A=A1,B:B))
Note: In newer Excel versions you might need to use the MODE.SNGL function instead.
Image 1: Column C uses the array formula with an IF condition.
For further information see Conditional mode with criteria.
For reference rather than the best answer, below is the VBA I wrote which completes the same task as the array formula from the other answers:
Sub mode2()
Dim lastrow As Long, x As Long, b As Long
Dim cel As Range, cel2 As Range
Dim rng() As Variant
b = 2
lastrow = Range("A" & Rows.count).End(xlUp).Row
For Each cel In Range("A2:A" & lastrow)
If cel.Value = cel.Offset(1, 0).Value Then
If (Not Not rng) = 0 Then
ReDim rng(0 To 0)
rng(0) = cel.Offset(, 1).Value
Else
ReDim Preserve rng(0 To (cel.Row - b))
rng(cel.Row - b) = cel.Offset(, 1).Value
End If
Else
ReDim Preserve rng(0 To (cel.Row - b))
rng(cel.Row - b) = cel.Offset(, 1).Value
If (Not Not rng) <> 0 Then
Range("C" & cel.Row).Value = Application.WorksheetFunction.mode(rng)
b = cel.Row + 1
Erase rng()
End If
End If
Next cel
End Sub
This is probably not the cleanest or best macro, but it works and maybe it will help someone when a formula isn't an option. (at least it'll be useful for me if I ever go code bowling)
Related
I have a table in an active worksheet.
I am trying to:
Scan Columns(A:M) of Row 6 to see if all cells are empty
If yes, then scan Columns (N:R) of Row 6 to see if all cells are empty
If 2. is false, then copy above row's Columns (A:I) in Row 6
Repeat 1-3 but on Row 7
This process should repeat until the rows of the table end.
I would like to incorporate ActiveSheet.ListObjects(1).Name or something similar to duplicate the sheet without having to tweak the code.
How I can make this as efficient and as risk free as possible? My code works but it's really too much.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim y As Long
Dim a As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
a = 0
For x = 6 To lr
For y = 1 To 13
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
If a = 0 Then
For y = 14 To 18
If Not IsEmpty(Cells(x, y)) Then
a = a + 1
End If
Next y
Else
a = 0
End If
If a <> 0 Then
For y = 1 To 13
Cells(x, y).Value = Cells(x - 1, y).Value
Next y
End If
a = 0
Next x
End Sub
This is the final code based on #CHill60 code. It got me 99% where I wanted.
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
'check columns A to M for this row are empty
Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
'check columns N to R for this row are empty
Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
'copy the data into columns A to M
Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
r3.Value = r3.Offset(-1, 0).Value
End If
Next x
End Sub
Instead of looking at individual cells, look at Ranges instead. Consider this snippet of code
Sub demo()
Dim x As Long
For x = 6 To 8
Dim r As Range
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
Debug.Print r.Address, MyIsEmpty(r)
Next x
End Sub
I have a function for checking for empty ranges
Public Function MyIsEmpty(rng As Range) As Boolean
MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function
I use this because the cell might "look" empty, but actually contain a formula.
Note I've explicitly said which sheet I want the Cells from - users have a habit of clicking places other than where you think they should be! :laugh:
Edit after OP comment:
E.g. your function might look like this
Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
a = 0
'check columns A to M for this row are empty
Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
If Not MyIsEmpty(r) Then
a = a + 1
End If
If a = 0 Then
'check columns N to R for this row are empty
Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
If Not MyIsEmpty(r2) Then
a = a + 1
End If
Else
a = 0
End If
If a <> 0 Then
'copy the data into columns A to M
'You might have to adjust the ranges here
r.Value = r2.Value
End If
Next x
End Sub
where you have a source range and a target range - you appear to be putting the values in the previous row so my value of r is probably wrong in this example - you could use r.Offset(-1,0).Value = r2.Value
I'm also not sure what you are trying to do with the variable a If that is meant to be a "flag" then consider using a Boolean instead - it only has the values True or False
my lrow is correct... But I want my Cells(I, matl.Column).Value to only call the visible cells. Right now its calling all cells. I've tried:
Cells.SpecialCells(xlCellTypeVisible).Select(I, matl.Column).Value
and that just gives me errors.
Lmk if this is even possible! Here's my code below!
lrow = Workbooks(tmpwb).Worksheets(mm).AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
For I = 3 To lrow
'For j = 0 To 16
session.findById("wnd[0]/usr/sub:SAPMM07M:0421/ctxtMSEG-MATNR[" & I - 3 & ",7]").Text = Cells(I, matl.Column).Value
Next I
Maybe something like this:
Dim col as Range, rngVis As Range, c As Range, I As Long
Set col = Workbooks(tmpwb).Worksheets(mm).AutoFilter.Range.Columns(1)
Set rngVis = col.SpecialCells(xlCellTypeVisible)
I = 3
For Each c In rngVis.Cells
If c.Row > col.Cells(1).Row Then 'skip the header
' `I` below may need to be `c.row-3` ?
session.findById("wnd[0]/usr/sub:SAPMM07M:0421/ctxtMSEG-MATNR[" & I - 3 & ",7]").Text = _
c.EntireRow.Columns(matl.Column).Value
I = I + 1
End If
Next c
Variance Table Sample I'm working on an Excel Macros (VBA) to look through every 3rd cell of each row in a data set and perform a copy paste action based on conditions (Please see the code at the bottom).
The source data is in a another worksheet (Variance). It has 1300+ IDs (rows) and 3 columns for each value component (col 1 - value 1, col 2 - value 2, and col 3 - the difference between the 2 values) and likewise there are 500+ columns.
My code basically looks through every third column (the difference column) of each row to find out if the value is a number, not equal to zero, and if it's not an error (there are errors in the source sheet). If yes, it copies the Emp ID, the column Name, and both the values into another worksheet called vertical analysis (one below the other).
The code works fine, but it takes 6 to 7 minutes for a data set with 1000+ rows and 500+ columns.
Can someone please tell me if there is a faster way to do this than to loop through each row?
Please let me know if you need more information. Thanks in advance.
Code:
Sub VerticalAnalysis()
Dim EmpID As Range
Dim i As Long
Dim cell As Range
Dim lastrow As Range
Dim LastCol As Long
Dim curRow As Long
Dim c As Long
Set lastrow = ThisWorkbook.Worksheets("Variance").Cells(Rows.Count, 2).End(xlUp)
Set EmpID = ThisWorkbook.Worksheets("Variance").Range("B4", lastrow)
LastCol = ThisWorkbook.Worksheets("Variance").Cells(3, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
MsgBox "Depending on the size of the record, your excel will not respond for several minutes during Vertical Analysis. Please don't close the workbook", , "Note: Please Don't Close the Workbook"
Worksheets("Vertical").Select
Range("B3", "H" & Rows.Count).ClearContents
Range("B3", "H" & Rows.Count).ClearFormats
ThisWorkbook.Worksheets("Variance").Select
c = 1
For Each cell In EmpID
i = 2
Do Until i >= LastCol
cell.Offset(0, i).Select
If IsError(ActiveCell) Then
ElseIf ActiveCell <> "" Then
If IsNumeric(ActiveCell) = True Then
If ActiveCell <> 0 Then
cell.Copy
Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(-c, -2).Copy
Worksheets("Vertical").Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -2).Copy
Worksheets("Vertical").Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
ActiveCell.Offset(0, -1).Copy
Worksheets("Vertical").Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
End If
End If
i = i + 4
Loop
c = c + 1
Next cell
ThisWorkbook.Worksheets("Vertical").Select
Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & Worksheets("Vertical").Range("B" & Rows.Count).End(xlUp).Row - 2 & " Components have variations", , "Success!"
Application.ScreenUpdating = True
End Sub
You might try to use SQL. In order to learn how to use sql in EXCEL VBA, I suggest you to follow this tuto and to apply your learn on your macro. They will be faster =)
https://analystcave.com/excel-using-sql-in-vba-on-excel-data/
Better not to hit the sheet so many times.
Below is tested and should run in a few seconds, but you may need to tweak the column positions etc:
Sub VerticalAnalysis()
Const BLOCK_SIZE As Long = 30000
Dim lastrow As Long
Dim LastCol As Long
Dim c As Long, wsVar As Worksheet, wsVert As Worksheet, n As Long
Dim data, r As Long, empId, v, rwVert As Long, dataVert, i As Long
Set wsVar = ThisWorkbook.Worksheets("Variance")
Set wsVert = ThisWorkbook.Worksheets("Vertical")
lastrow = wsVar.Cells(Rows.Count, 2).End(xlUp).Row
LastCol = wsVar.Cells(3, Columns.Count).End(xlToLeft).Column
'get all the input data as an array (including headers)
data = wsVar.Range("A3", wsVar.Cells(lastrow, LastCol)).Value
'clear the output sheet and set up the "transfer" array
With wsVert.Range("B3", "H" & Rows.Count)
.ClearContents
.ClearFormats
End With
rwVert = 3 'first "vertical" result row
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4) 'for collecting matches
i = 0
n = 0
For r = 2 To UBound(data, 1) 'loop rows of input array
empId = data(r, 2) 'colB ?
c = 7 'first "difference" column ?
Do While c <= UBound(data, 2)
v = data(r, c)
If Not IsError(v) Then
If IsNumeric(v) Then
If v > 0.7 Then
i = i + 1
n = n + 1
dataVert(i, 1) = empId
dataVert(i, 2) = data(1, c) 'header
dataVert(i, 3) = data(r, c + 2) 'value1
dataVert(i, 4) = data(r, c + 1) 'value2
'have we filled the temporary "transfer" array?
If i = BLOCK_SIZE Then
wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
i = 0
ReDim dataVert(1 To BLOCK_SIZE, 1 To 4)
rwVert = rwVert + BLOCK_SIZE
End If
End If
End If
End If
c = c + 4 'next difference
Loop
Next r
'add any remaining
If i > 0 Then wsVert.Cells(rwVert, 2).Resize(BLOCK_SIZE, 4).Value = dataVert
wsVert.Select
wsVert.Range("B2").Select
MsgBox "Analysis complete " & vbCrLf & n & " Components have variations", , "Success!"
End Sub
Trying to loop two columns and put result into one column.
1) looping is incorrect (no hits = wrong)
2) printing puts result into two different columns ("O" +7 from H and "R" +7 from K).
Private Sub FindValueKH_JN()
'New column O (no 15)
'Find if value starting in column H (no8) is between 207100-208100
'AND if value starting in column K (no11) is between 12700-12729,
' then T2J in column O, else T2N in O
Range("O1").Select
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "T2 er Ja eller Nei"
Dim loopRange As Range
'From H to new column O is +7 columns
lastrow1 = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row
'From K to new column O is +4 columns
lastrow2 = ActiveSheet.Cells(Rows.Count, "K").End(xlUp).Row
'loop columns H and K
Set loopRange = Union(Range("H2:H" & lastrow1), Range("K2:K" & lastrow2))
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And _
Left(cell.Value, 5) >= 12700 And Left(cell.Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
End Sub
Your references are incorrect, and this is why you are not getting any hits. You want to check two separate columns for specific values, but instead are just looking in one single cell for both conditions:
For Each cell In loopRange will loop through every cell in your defined loopRange range, which contains both columns.
You'd have to change your code so it loops through just a single column instead, like the following
Dim loopRange As Range
lastrow = ActiveSheet.Cells(Rows.Count, "H").End(xlUp).Row 'From H to new column O is +7 columns
Set loopRange = Range("H2:H" & lastrow1) 'loop columns H
For Each cell In loopRange
If Left(cell.Value, 6) >= 207100 And Left(cell.Value, 6) <= 208100 And Left(cell.Offset(, 3).Value, 5) >= 12700 And Left(cell.Offset(, 3).Value, 5) <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else: cell.Offset(0, 7).Value = "T2N"
End If
Next cell
In your If-statement, you are checking the content of a single cell and your If-statement can never be true. With your Union-statement, you will get a Range with all cells of Col H and all cells of Col K, and in the loop you are checking all cells that are either in H or in K.
So your If hits, for example, Cell H2 and you are checking if the content is > 207100 and in the same moment < 12729.
What you probably want is to loop over all cells if column H, check it's value together with the value of the cell in column K of the same row.
I assume your cells contain a string starting with a number but holds also some characters. I would advice that you write the values into intermediate variables, makes it much easier to debug. You are using the left-function which will give you the first 6 (resp. 5) characters. The result is still a string (even if it contains only digits), and you compare it to a number, and that's not a good idea because now VBA has to do some implicit conversions, and that may lead to unexpected results. You should use the Val-function to convert a string into a numeric value.
As already mentioned in the comments, never work implicit on the so called Active Worksheet. Specify explicitly the worksheet you want to work with.
One question: Why do you use the strange syntax for the Else-statement. The : means that you put a second statement into a line. It is much more readable to omit the : and put the next statement(s) into separate lines.
Dim loopRange As Range, cell As Range, lastrow As Long
With ThisWorkbook.Sheets(1)
lastrow = .Cells(Rows.Count, "H").End(xlUp).row
Set loopRange = .Range("H2:H" & lastrow)
End With
For Each cell In loopRange
Dim valH As Long, valK As Long
valH = Val(Left(cell.Value, 6))
valK = Val(Left(cell.Offset(0, 3).Value, 6))
If valH >= 207100 And valH <= 208100 And valK >= 12700 And valK <= 12729 Then
cell.Offset(0, 7).Value = "T2J"
Else
cell.Offset(0, 7).Value = "T2N"
End If
Next cell
I am relatively new to VBA, and any help to get this problem solved will be greately appreciated!
I want Excel to look at two columns of text values, and only return the unique ones, for both columns. But I want the two columns to "correspond" to one another, so that the unique values for the first column is returned, and the unique values corresponding to each of the unique values in that column is returned next to it.
I.e. if the columns are the following:
Column 1: a a a d d g g g g
And the second column's values are
Column 2: 3 3 2 1 1 7 8 8 9
I would like to first look at column 1. Here, the first unique value is a. Then, take all the unique values in column 2 (i.e. 3 and 2). So (1,1)=a, (1,2)=3, (2,2)=2 and (2,1)=empty. Then, below, is the next unique value, so (3,1)=d, (3,2)=2, (4,1)=empty and (4,2)=1. Then (5,1)=g, and (5,2)=7, (6,1)=empty, (6,2)=8, (7,1)=empty, and (7,2)=9.
It's a little tricky to explain, but I hope it is still possible to get the point!
Thank you!
This code will do that for you
Option Explicit
Sub Main()
Dim r1 As Range
Set r1 = Application.InputBox(prompt:="Select first range", Type:=8)
Dim r2 As Range
Set r2 = Application.InputBox(prompt:="Select second range", Type:=8)
If r1.Rows.Count <> r2.Rows.Count Then
MsgBox "ranges aren't equal in rows, restart the macro!", vbCritical
Exit Sub
End If
ReDim arr(0) As String
Dim i As Long
For i = 1 To r1.Rows.Count
arr(UBound(arr)) = r1.Rows(i) & "###" & r2.Rows(i)
ReDim Preserve arr(UBound(arr) + 1)
Next i
RemoveDuplicate arr
ReDim Preserve arr(UBound(arr) - 1)
With Sheets(2)
.Activate
.Columns("A:B").ClearContents
For i = LBound(arr) To UBound(arr)
.Range("A" & i + 1) = Split(arr(i), "###")(0)
.Range("B" & i + 1) = Split(arr(i), "###")(1)
Next i
For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
If StrComp(.Range("A" & i).Offset(-1, 0), .Range("A" & i), vbTextCompare) = 0 Then
.Range("A" & i) = vbNullString
End If
Next i
End With
End Sub
Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B
tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub
What happens is you are asked to select each column with your mouse. So assuming your spreadsheet looks somehow like below picture then select your two desired columns. First column and then you will be asked for the second one. (select whats in red)
Repeat for the second column and your results will be reprinted in Sheet2