In sheet "Selection" I input a Gender (M or F) in column A, and a corresponding value in column B.
In sheet "Sizes", I have lists of the available sizes for each gender, like this.
In sheet "Selection", I want it to write on Column C the corresponding size (that must be always be higher than column B). If there is not an available size, it must write "Not available!"
Enter the following formula in Cell C2 of Selection sheet
=IFERROR(IF(A2="M",INDEX(Sizes!$A$3:$A$10,MATCH(TRUE,Sizes!$A$3:$A$10>B2,0)),INDEX(Sizes!$B$3:$B$10,MATCH(TRUE,Sizes!$B$3:$B$10>B2,0))),"Not Available")
This is an array formula so commit it by pressing Ctrl+Shift+Enter. Drag/Copy down as required.
See image for reference
EDIT :
Following is VBA solution:
Sub Demo()
With Application
.ScreenUpdating = False 'stop screen flickering
.Calculation = xlCalculationManual 'prevent calculation while execution
End With
Dim selectionSht As Worksheet, sizeSht As Worksheet
Dim selectionLR As Long, sizeLR As Long, lastColumn As Long
Dim dict As Object
Dim rng As Range, cel As Range, genderRng As Range, valueRng As Range
Dim key As Variant
Dim colName As String
Set dict = CreateObject("Scripting.Dictionary")
Set selectionSht = ThisWorkbook.Sheets("Selection") 'Selection sheet
Set sizeSht = ThisWorkbook.Sheets("Sizes") 'Sizes sheet
selectionLR = selectionSht.Cells(selectionSht.Rows.Count, "A").End(xlUp).Row 'last row in Selection sheet
sizeLR = sizeSht.Cells(sizeSht.Rows.Count, "A").End(xlUp).Row 'last row in Sizes sheet
lastColumn = sizeSht.Cells(2, sizeSht.Columns.Count).End(xlToLeft).Column 'last column in Sizes sheet using row 2
Set valueRng = selectionSht.Range("B2:B" & selectionLR) 'data with value in Selection sheet
'storing all genders and corresponding column number from Sizes sheet in a dictionary
With sizeSht
Set rng = .Range(.Cells(2, 1), .Cells(2, lastColumn))
For Each cel In rng
dict.Add cel.Value, cel.Column
Next cel
End With
With selectionSht
For Each cel In .Range(.Cells(2, 3), .Cells(selectionLR, 3)) '3 is column no for results to be displayed
colName = Replace(.Cells(1, dict(CStr(cel.Offset(0, -2)))).Address(True, False), "$1", "") 'get column name from column 2
Set genderRng = sizeSht.Range(colName & "3:" & colName & sizeLR) 'set column for index/match formula
cel.FormulaArray = "=IFERROR(INDEX(Sizes!" & genderRng.Address & ",MATCH(TRUE,Sizes!" & genderRng.Address & ">" & cel.Offset(0, -1) & ",0)),""Not Available"")"
cel.Value = cel.Value
Next cel
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Let me know if anything is not clear.
You can use this (normal) formula in C2 and fill down:
C2:
=IFERROR(AGGREGATE(15,6,Sizes!$A$3:$B$10
/(Sizes!$A$2:$B$2=A2)/(Sizes!$A$3:$B$10>=B2),1), "Not Available!")
Related
Hi im trying to create a function in VBA which scans the top row and inserts a filter on a particular cell in the third row if the corresponding cell in the top row contains a value, if a cell is empty then it should skip to the next cell. The third row will be a header row.
Here is some code:
Sub FilterRefresh()
Dim i As Long, lastCol As Long
Dim rng As Range, cell As Range
Dim wSheet As Worksheet
Set wSheet = Worksheets("Machining")
'find the last column in row one
lastCol = wSheet.Cells(1, Columns.Count).End(xlToRight).Column 'xlToLeft
'set range from A1 to last column
Set rng = wSheet.Range(Cells(1, 1), Cells(1, lastCol)) 'will be a higher cell range
'Outline the autofilter field hierarchy
i = 1
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.row + 2, i + 1).AutoFilter Field:=i, Criteria1:=cell.Value
i = i + 1
End If
Next cell
End Sub
Try this:
For Each cell In rng
If cell.Value <> "" Then
wSheet.Cells(cell.Row + 2, cell.Column).AutoFilter Field:=cell.Column, Criteria1:=cell.Value
End If
Next cell
This is what my end result should look like. If there is not the four digits to move over to the second column then fill with 4 zeros.
How can I split zip code in a column into 2 columns and fill empty cells in column 2 if first column has only 5 digits?
Here is what I have been working with
Dim ws As Worksheet
Dim cell As Range
Set ws = Worksheets("sheet1")
For Each cell In ws.Range("K2:K500").Cells
cell.Offset(0, 1).Value = Left(cell.Value, 5)
Next cell
Dim cel As Range, rngC As Range, rngB As Range
Dim lastRowA As Long, lastRowB As Long
With ws
lastRowK = .Cells(.Rows.Count, "K").End(xlUp).Row 'last row of column A
lastRowL = .Cells(.Rows.Count, "L").End(xlUp).Row 'last row of column B
For Each cel In .Range("K2:K" & lastRowL) 'loop through column L
'check if cell in column A exists in column B
If WorksheetFunction.CountIf(.Range("K2:K" & lastRowL), cel) = 0 Then
cel.Offset(0, 3).Value = Right(cel.Value, 4)
'.Range("M" & cel.Row) = Right(cell.Value, 4)
Else
.Range("M" & cel.Row) = "0000"
End If
Next
End With
In case you want to bypass VBA and use formulas, you can do this.
Cell B2:
=LEFT(A2,5)
Cell C2:
=IF(LEN(A2)=9,RIGHT(A2,4),"0000")
One of the simplest ways to solve this problem is to supplement the original string with a large number of zeros and take the values of the first and second five characters for two cells:
Sub setZIPandZeros()
Const TEN_ZEROS = "0000000000" ' 10 times
Dim ws As Worksheet
Dim cell As Range
Dim sLongString As String
Set ws = Worksheets("Sheet1")
For Each cell In ws.Range("K2:K" & ws.Cells(ws.Rows.Count, "K").End(xlUp).Row).Cells
sLongString = Trim(cell.Text) & TEN_ZEROS
cell.Offset(0, 1).Resize(1, 2).NumberFormat = "#"
cell.Offset(0, 1).Resize(1, 2).Value = Array(Left(sLongString, 5), _
Mid(sLongString, 6, 5))
Next cell
End Sub
Update The modified code is much faster and gives a result that more closely matches the description of the task:
Sub setZipZeros()
Dim ws As Worksheet
Dim rResult As Range
Set ws = Worksheets("Sheet1")
' Addressing R1C1 is used in the formulas - If the original range
' is shifted to another column, you will need to change the letter
' of the column "K" only in this line
Set rResult = ws.Range("K2", ws.Cells(ws.Rows.Count, "K").End(xlUp)).Offset(0, 1)
' If the columns L:M are already in text format, then instead of
' the results we will get the texts of formulas
rResult.Resize(, 2).NumberFormat = "General"
' These two lines do most of the work:
rResult.Formula2R1C1 = "=LEFT(TRIM(RC[-1])&""00000"",5)"
rResult.Offset(0, 1).Formula2R1C1 = "=MID(TRIM(RC[-2])&""000000000"",6,4)"
' We don't know if auto-recalculation mode is on now
' Application.Calculation = xlAutomatic
ActiveSheet.Calculate
Set rResult = rResult.Resize(, 2)
' Set the text format for the cells of the result
' to prevent conversions "00123" to "123"
rResult.NumberFormat = "#"
' Replace formulas with their values
rResult.Value = rResult.Value
End Sub
I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell
Using VBA in excel, I am wanting to incorporate the formula located in column "O", shown below, for all B rows that have a value starting at B9. Please reference the image.
=""&D9&" "&I9&" (MK NO. "&B9&")"
This should do what your are looking for.
Sub Pasteformula()
Dim LookupRange As Range
Dim c As Variant
Application.ScreenUpdating = False
Set LookupRange = Range("B9:B500") ' Set range in Column B
For Each c In LookupRange 'Loop through range
If c.Value <> "" Then 'If value in B is empty then
Cells(c.Row, 15).FormulaR1C1 = _
"=""""&RC[-11]&"" ""&RC[-6]&"" (MK NO. ""&RC[-13]&"")""" 'Apply formula
End If
Next c
Application.ScreenUpdating = True
End Sub
Set the range and enter the formula, then change the range to values.
Sub Button1_Click()
Dim rng As Range
Set rng = Range("O9:O" & Cells(Rows.Count, "B").End(xlUp).Row)
rng.Formula = "=CONCATENATE(D9,"" "",I9,"" (MK NO. "",B9,"")"")"
rng.Value = rng.Value
End Sub
from your narrative I get that you already have the proper formula in O9, hence you could use AutoFill() method of Range object:
Range("O9").AutoFill Range("B9", Cells(Rows.Count, "B").End(xlUp)).Offset(,13)
I have a value in Column A which I want to write to a separate sheet, there are column and row numbers which specify the location I want to write that value in the same row as the value in column A.
For instance the value in A8 has column number "2" in Q8 and row number "118" in S8. So I want to write a formula in the new sheet which puts the value of A8 into cell B118 in the new sheet. And for this to go down with all the values in A:A as the first sheet continues to be filled in.
I've tried doing this with sumifs formula here but its not quite working out;
=IF(SUMIFS(sheet1!$A:$A,sheet1!$Q:$Q,COLUMN(B8),sheet1!$S:$S,ROW(B8))," ",sheet1!$A:$A)
If you want the formula in the new sheet to reference the cell in Sheet1 then:
Sub marine()
Dim cl As Long, rw As Long, source As String
cl = Range("Q8").Value
rw = Range("S8").Value
Sheets("new").Cells(rw, cl).Formula = "=Sheet1!A8"
End Sub
and if you simply want A8's value transferred to the new sheet, then:
Sub marine2()
Dim cl As Long, rw As Long, source As String
cl = Range("Q8").Value
rw = Range("S8").Value
Sheets("new").Cells(rw, cl).Value = Range("A8").Value
End Sub
EDIT#1:
Here is a version that will handle the entire column:
Sub marine3()
Dim cl As Long, rw As Long, source As String
Dim i As Long, N As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
For i = 8 To N
cl = Range("Q" & i).Value
rw = Range("S" & i).Value
If cl <> 0 And rw <> 0 Then
Sheets("new").Cells(rw, cl).Value = Range("A" & i).Value
End If
Next i
End Sub
Here is my answer.
Sub movindData()
'take all the data from sheet1 and move it to sheet2
Dim sht2 As Worksheet
Dim r
Dim c
Dim i
Dim rng As Range
Dim A 'for each value in column A
Dim Q 'for each value in column Q (the column)
Dim S 'for each value in column S (the row)
r = Range("A1").End(xlDown).Row 'the botton of columns A, the last row
'I take the inicial cells as a A1, but you
'can change it as you need.
c = 1 'the column A
Set rng = Range(Cells(1, 1), Cells(r, c)) 'this takes just the range with the data in columns A
Set sht2 = Sheets("Sheet2")
For Each i In rng
A = i.Value 'Store the value of every cell in column A
Q = i.Offset(0, 16).Value 'Store the value of every cell in column Q (the destination column in sheet2)
S = i.Offset(0, 18).Value 'Store the value of every cell in column s (the destination row in sheet2)
sht2.Cells(Q, S).Value = A
Next i
End Sub