I have a worksheet. I want to clear the contents of cells 17-37, 45-60, 65-79; with the column being determined by the header (in Row 15) being equal to the value in Cell B1 of same worksheet. My sheet has columns C-Z to be looked at.
I tried to write a loop, or use other parts of code found online and I am unable to add the lookup so that it will only clear in the column if the value in row 15 of the column matches B1.
EDIT: Here is what I had so far, based on comments but it still will not find my value so cindex returns Error 2042 - checked for leading or trailing spaces.
Set ws to FORECAST
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("FORECAST")
'Set range to search
Dim hrg As Range
Set hrg = ws.Range("C15:Z15")
'set range to clear contents
Dim crg As Range
Set crg = ws.Range("17:37,45:60,65:79")
'Set header value to find
Dim Header As Variant
Header = ws.Range("B1").Value
'hold column where match is found
Dim cIndex As Variant
cIndex = Application.Match(Header, hrg, 0)
'validate column index and clear
If IsNumeric(cIndex) Then
Intersect(hrg.Cells(cIndex).EntireColumn, crg).Clear
'else no match found; no nothing
End If
End Sub
Clear Cells When Matching Header
Sub ClearColumn()
' Worksheet
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Header Range
Dim hrg As Range: Set hrg = ws.Range("C15:Z15")
' Clear-Entire-Rows Range
Dim crg As Range: Set crg = ws.Range("17:37,45:60,65:79")
' Header (Value)
Dim Header As Variant: Header = ws.Range("B1").Value
' Column Index (index of the matching cell (column)
' of the Header range (if a match))
Dim cIndex As Variant: cIndex = Application.Match(Header, hrg, 0)
' Validate the Column index and clear.
If IsNumeric(cIndex) Then ' match found
Intersect(hrg.Cells(cIndex).EntireColumn, crg).Clear
'Else ' no match found; do nothing
End If
End Sub
Solution
Sub ClearByHeaderName()
Dim criteriaCell As Range
Dim headerCells As Range
Dim headerCell As Range
Dim isColumnCleared As Boolean
Set criteriaCell = Range("B1")
If criteriaCell.Value = "" Then
MsgBox "Provide column name in B1!", vbExclamation
End
End If
Set headerCells = Range("C15:Z15")
For Each headerCell In headerCells
If headerCell.Value = criteriaCell.Value Then
ClearDataCells headerCell
isColumnCleared = True
End If
Next
If isColumnCleared Then
MsgBox "Done!", vbInformation
Else
MsgBox "Cannot find column '" & criteriaCell.Value & "'!", vbExclamation
End If
End Sub
Private Sub ClearDataCells(headerCell As Range)
With headerCell.EntireColumn
.Rows("17:37").Clear
.Rows("45:60").Clear
.Rows("65:79").Clear
End With
End Sub
Related
I am trying to learn vba and I have this list. For every NAME there will be an individual worksheet created. If the name of the worksheet match the name on the list I need to put the length in cell J1. I tried to use if ... elseif ... but knowing I have 430 different names the code will be too long what should I do? What alternative code can I use?
Sub length()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "A" Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = 4153
ElseIf ws.Name = "B" Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = 2273
Next
MsgBox "DONE"
End Sub
Sub length()
Dim Cell as Range
For Each Cell In Range("Name")
On Error Resume Next
ThisWorkbook.Sheets(Cell.Value).Range("J1") = Cell.Offset(0, 1)
If Err.Number <> 0 Then Debug.Print "Sheet " & Cell & " wasn't found"
On Error GoTo 0
Next Cell
MsgBox "DONE"
End Sub
Range("Name") needs to be changed to refer to the real range with the sheet names.
On Error ... can be removed if you're sure that all mentioned worksheets exist.
Write Values to Worksheets From a List
This will loop through the list of names. There may be worksheets whose names are not on the list.
Adjust the name of the worksheet containing the list (Sheet1) and the column (A) and row (2) of the first name.
Option Explicit
Sub CopyLengths()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source worksheet ('sws').
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
' Calculate the last row ('slRow'), the row of the last non-empty cell
' in the worksheet names column.
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
' Reference the source range ('srg'), the one-column range
' containing the worksheet names.
Dim srg As Range: Set srg = sws.Range("A2", sws.Cells(slRow, "A"))
Dim dws As Worksheet ' Destination Worksheet
Dim sCell As Range ' Current Source (Name) Cell
Dim sString As String ' Current Source String
' Copy lenghts.
' Loop through the cells ('sCell') of the source range...
For Each sCell In srg.Cells
' Convert the current cell's value to a string ('CStr')
' and write the string to a variable ('sString').
sString = CStr(sCell.Value)
' Check if the string is not an empty string...
If Len(sString) > 0 Then ' the cell is not blank
' Attempt to reference the worksheet named after the string.
On Error Resume Next
Set dws = wb.Worksheets(sString)
On Error GoTo 0
If Not dws Is Nothing Then ' worksheet found (referenced)
' Copy (write) the length.
dws.Range("J1").Value = sCell.Offset(, 1).Value
Set dws = Nothing ' reset the variable
'Else ' worksheet not found (not referenced); do nothing or e.g. ...
'Debug.Print "Worksheet '" & sString & "' not found"
End If
'Else ' the cell is blank; do nothing
End If
Next sCell
' Inform.
MsgBox "Lengths copied.", vbInformation
End Sub
Sub UpdateSheets()
Dim vTable As Variant
Dim iRow As Long
' SHEET_NAME: The sheets name containing the table: Name, LENGTH
' RANGE: the range where the sheet names are listed (without the header)
' vTable: the table with 'Name' & 'LENGTH' column values in memory
vTable = ThisWorkbook.Worksheets("SHEET_NAME").Range("I2:J7").Value2
For iRow = LBound(vTable, 1) To UBound(vTable, 1) ' iRow: current row in table
' vTable(iRow, 1): 'Name' column value
' vTable(iRow, 2): 'LENGTH' column value
On Error Resume Next
ThisWorkbook.Worksheets(CStr(vTable(iRow, 1))).Range("J1").Value2 = vTable(iRow, 2)
On Error GoTo 0
If Err.Number <> 0 Then
' DO SOMETHING IF ERROR IS THROWN (CREATE MISSING WORKSHEET)
Err.Clear
End If
Next iRow
MsgBox "DONE"
End Sub
If you have any questions don't hesitate!
Cheers, Peter.
Assuming that the columns are as on the image, you can do this:
Sub fnPickLength()
Dim ws As Excel.Worksheet
Dim oCell As Excel.Range
Dim oRng As Excel.Range
Set oRng = Range("rngTheNames") 'name the range with this name
For Each ws In ThisWorkbook.Worksheets
For Each oCell In oRng
If UCase(ws.Name) = UCase(oCell.Value) Then
ws.Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = oCell.Offset(0, 1).Value
Exit For
End If
Next
Next
MsgBox "DONE"
End Sub
Please adapt the named range as you want. I've choosen as "rngTheNames".
The ws name is compared with each oCell value. If matched, the Offset property reads the sibling cell of the evaluated name and put its value on the ws.
Can you help me with this Please, I'm trying to check if from range ("L2") to the end if result = "-" pop up a msgbox & colorize the range.
the conditions is all the cells value in the range horizontally must be = "-"
Example of what I mean:
I try to the below code but it's colorized all the value ("-") in the range
Sheets("Cumulated BOM").Activate
Dim i As Long
Dim c As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("L2", Range("L" & Row.Count).End(xlUp))
For Each myCell In myRange
c = c + 1
If (myCell) = "-" Then
myCell.Interior.Color = RGB(255, 87, 87)
i = i + 1
End If
Next myCell
Highlight Rows With All Their Cells Containing the Same Value
Option Explicit
Sub HighlightInvalidRows()
' Prepare.
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Cumulated BOM")
' Reference the range ('rg').
Dim rg As Range
Set rg = ws.Range("L2", "S" & ws.Cells(ws.Rows.Count, "L").End(xlUp).Row)
' Write the number of columns of the range to a variable ('CellsCount').
Dim CellsCount As Long: CellsCount = rg.Columns.Count
' Each row of the range has this number of columns (cells).
' Remove all range colors.
rg.Interior.Color = xlNone
' Combine the rows ('rrg') to be highlighted
' into the Highlight range ('hrg').
' Declare variables that appear for the first time in the following loop.
Dim hrg As Range
Dim rrg As Range
Dim MatchCount As Long
' Loop through the rows of the range.
For Each rrg In rg.Rows
' Write the number of appearances of the value in the current row
' to a variable ('MatchCount').
MatchCount = Application.CountIf(rrg, "-")
' Compare the match count with the cells count.
If MatchCount = CellsCount Then ' the numbers are equal
' Combine the current row into the highlight range.
If hrg Is Nothing Then ' the first match
Set hrg = rrg
Else ' all other matches
Set hrg = Union(hrg, rrg)
End If
'Else ' the numbers are not equal; do nothing
End If
Next rrg
' Highlight the rows (in one go) and inform.
If hrg Is Nothing Then ' no matches found
MsgBox "No invalid rows found.", vbInformation
Else ' matches found
hrg.Interior.Color = RGB(255, 87, 87)
MsgBox "Invalid rows highlighted.", vbExclamation
End If
End Sub
So I have a worksheet called "gar_nv" containing in its first row some strings that I'd like to define as names for my columns. For instance, first cell of column A is "Number", I'd like to refer to the column A(starting from the second cell) as "Number" instead of column "A".
Sub NameCol()
Dim LastRow As Long
Dim x As Long, Rng As Range
With gar_nv
For x = 1 To .UsedRange.Columns.Count
LastRow = Cells(Cells.Rows.Count, x).End(xlUp).Row
Set Rng = Cells(2, x).Resize(LastRow)
.Names.Add Name:=Cells(1, x), RefersTo:=Rng
Set Rng = Nothing
Next
End With
End Sub
When I test my code like this, it throws a 91 error, what am I doing wrong?
Sub test()
With gar_nv
For Each Rng In .Range("Number")
MsgBox (Rng.Value)
Next
End With
End Sub
Create Names for Columns of Data
gar_nv is the code name of a worksheet in the workbook containing this code.
Option Explicit
Sub NameColumnsData()
' Delete all previous names in the worksheet.
'DeleteAllWorksheetNames gar_nv
Dim hrg As Range ' header range
Dim drg As Range ' data range
Dim cCount As Long ' number of columns
With gar_nv.UsedRange
Set hrg = .Rows(1)
Set drg = .Resize(.Rows.Count - 1).Offset(1)
cCount = .Columns.Count
End With
Dim crg As Range
Dim c As Long
Dim cTitle As String
For c = 1 To cCount
cTitle = hrg.Cells(c).Value
Set crg = drg.Columns(c)
gar_nv.Names.Add cTitle, crg
' Of course, you can lose the variables and just do:
'gar_nv.Names.Add hrg.Cells(c).Value, drg.Columns(c)
Next c
MsgBox "Column data names created.", vbInformation
End Sub
Sub NameColumnsDataTEST()
Dim cCell As Range
With gar_nv
For Each cCell In .Range("Number").Cells
' Caution! If there are many cells it may take 'forever'.
'MsgBox cCell.Address(0, 0) & ": " & cCell.Value
' Rather print to the Immediate window (Ctrl+G):
Debug.Print cCell.Address(0, 0) & ": " & cCell.Value
Next
End With
End Sub
Sub DeleteAllWorksheetNames(ByVal ws As Worksheet)
Dim nm As Name
For Each nm In ws.Names
Debug.Print nm.Name, nm.RefersTo, "Deleted!"
nm.Delete
Next nm
End Sub
I need some help. I have two columns: A and B. Column A and Column B have the following headers "Status" and "State". A filter has been applied to select "down" from a choice of "up" and "down" in Column A. When Column A is filtered some blank cells are revealed in Column B after some cells in Column B is cleared. The amount of data in the sheet varies and the position of these blanks also vary. I will like to fill down these blank cells in Column B using the values in visible cells only (not from the values in the hidden cells). Can someone help me edit this code?
In the pic above SO will fill down from 50476 to 50492 without erasing the values in the hidden cells.
Sub Filldownvisiblecells ()
Dim ws as worksheet
Dim dl as long
Dim rg as range
ws = Workbooks("Book1.xlsm"). Worksheets("Sheet1")
dl = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'Filter Column A by Down
ws.Range("A1").AutoFilter Field:=1, Criteria1:="Down"
'Clearing States in Column B (This action generates blanks that I will like to filldown from visible cells NOT hidden cells)
ws.Range("B2:B" & dl).SpecialCells(xlCellTypeVisible).Select
For Each rg In Selection.Cells
If rg.Text = "R1" Or rg.Text = "R2" Or rg.Text = "UT" Then
rg.ClearContents
End If
Next rg
'Select Filldown Range in Column B
ws.Range("B2:B" & dl). SpecialCells(xlCellTypeVisible).Select
'Filldown Blanks in Column X
For Each rg In Selection.Cells
If rg.Value = "" Then
rg.FillDown
End If
Next rg
End Sub
Fill Down With Visible Cells' Values (AutoFilter)
Option Explicit
Sub FillDownVisible()
Const wsName As String = "Sheet1"
Const fRow As Long = 1 ' First Row
Const fCol As String = "A" ' Filter Column
Const fCriteria As String = "Down" ' Filter Criteria
Const dCol As String = "B" ' Destination Column
Dim ws As Worksheet
' The Workbook Containing This Code ('ThisWorkbook')
Set ws = ThisWorkbook.Worksheets(wsName)
' An Open Workbook
'Set ws = Workbooks("Book1.xlsm").Wordksheets(wsname)
' Possibly Closed Workbook (Needs the Full File Path)
'Set ws = Workbooks.Open("C:\Test\Book1.xlsm").Worksheets(wsName)
' Clear possible previous ('active') filter.
If ws.AutoFilterMode Then
ws.AutoFilterMode = False
End If
' Create a reference to the Filter Range ('frg').
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, fCol).End(xlUp).Row
Dim frg As Range: Set frg = ws.Cells(fRow, fCol).Resize(lRow - fRow + 1)
' Create a reference to the Destination Data Range (no headers).
Dim ddrg As Range: Set ddrg = frg.EntireRow.Columns(dCol) _
.Resize(frg.Rows.Count - 1).Offset(1)
' Filter Filter Range.
frg.AutoFilter Field:=1, Criteria1:=fCriteria
' Create a reference to the Destination Range ('drg').
Dim drg As Range: Set drg = ddrg.SpecialCells(xlCellTypeVisible)
Dim dCell As Range ' Current Destination Cell
Dim pValue As Variant ' Previous Value
Dim cValue As Variant ' Current Value
' Loop through the cells of the Destination Range.
For Each dCell In drg.Cells
cValue = dCell.Value
Select Case UCase(CStr(cValue))
Case "R1", "R2", "UT", ""
dCell.Value = pValue
Case Else
pValue = cValue
End Select
Next dCell
ws.AutoFilterMode = False
End Sub
The task I'm trying to accomplish is if Cells G21 to G27 have any text in them, then a vlookup formula will be pasted into the respective cell to the left of it
eg. Cell G31 has text so the formula =VLOOKUP(G31,Data!$P$2:$Q$110,2,FALSE) is in cell F31
This is the code I have so far, but I'm a beginner and I can't figure out how to insert the vlookup to automatically reference the cell next to it.
Private Sub Worksheet_Caps()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("G31:G27")
For Each cel In SrchRng
If cel.Value <> "" Then
cel.Offset(0, -1).Value= VLOOKUP(cel,Data!P2:Q110,2,FALSE)
End If
End Sub
VLookup vs Match
Both solutions will write values (not formulas) since you wrote "I originally wanted it to calculate in the VBA, but I couldn't figure that out!" in the comments.
A Quick Fix (Not Recommended)
Option Explicit
Sub Worksheet_Caps()
Dim SrchRng As Range: Set SrchRng = Range("G21:G27")
Dim LkpRng As Range: Set LkpRng = Worksheets("Data").Range("P2:Q110")
Dim SrchCell As Range
Dim MatchValue As Variant
For Each SrchCell In SrchRng.Cells
If Len(CStr(SrchCell.Value)) > 0 Then
MatchValue = Application.VLookup(SrchCell.Value, LkpRng, 2, False)
If Not IsError(MatchValue) Then
SrchCell.Offset(, -1).Value = MatchValue
'Else
'SrchCell.Offset(, -1).Value = Empty
End If
End If
Next SrchCell
End Sub
An Improvement
The following uses the more flexible Application.Match instead of any 'flavor' of VLookup.
Adjust (play with) the values in the constants section.
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Performs a 'VLookup' using 'Application.Match'.
' Remarks: Uses the 'RefColumn' and 'GetRange' functions.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub WorksheetCaps()
On Error GoTo ClearError
' Source
Const sName As String = "Data" ' Worksheet Name
Const slFirst As String = "P2" ' First Lookup Cell Address
Const svCol As String = "Q" ' Value Column
' Destination
Const dName As String = "Sheet1" ' Worksheet Name
Const dlFirst As String = "G21" ' First Lookup Cell Address
Const dvCol As String = "F" ' Value Column
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Lookup Range ('slrg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim slfCell As Range: Set slfCell = sws.Range(slFirst)
Dim slrg As Range: Set slrg = RefColumn(slfCell)
If slrg Is Nothing Then Exit Sub ' no data in source
' You can always use a static range instead of the previous 3 lines:
'Dim slrg As Range: Set slrg = sws.Range("P2:P110")
' Create a reference to the Destination Lookup Range ('dlrg').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlfCell As Range: Set dlfCell = dws.Range(dlFirst)
Dim dlrg As Range: Set dlrg = RefColumn(dlfCell)
If dlrg Is Nothing Then Exit Sub ' no data in destination
' You can always use a static range instead of the previous 3 lines:
'Dim dlrg As Range: Set dlrg = dws.Range("G21:G27")
' Create a reference to the Source Value Range ('svrg').
Dim svrg As Range: Set svrg = slrg.EntireRow.Columns(svCol)
' Write the values from the Source Value Range
' to the Source Value Array ('svData').
Dim svData As Variant: svData = GetRange(svrg)
' Write the values from the Destination Lookup Range
' to the Destination Array ('dData').
Dim dData As Variant: dData = GetRange(dlrg)
' Declare additional variables.
Dim smrIndex As Variant ' Source Match Row Index
Dim dlValue As Variant ' Destination Lookup Value
Dim dr As Long ' Destination Row Counter
' Loop through the elements (rows) of the Destination Array.
For dr = 1 To UBound(dData, 1)
' Write the (lookup) value of the current element
' in the Destination Array to a variable ('dlValue').
dlValue = dData(dr, 1)
' Replace the (lookup) value of the current element
' in the Destination Array with 'Empty'.
dData(dr, 1) = Empty
If Not IsError(dlValue) Then ' not an error value
If Len(dlValue) > 0 Then ' not a blank
' Attempt to find a match of the current
' Destination Lookup value in the Source Lookup Range.
smrIndex = Application.Match(dlValue, slrg, 0)
If IsNumeric(smrIndex) Then ' a match (the first occurrence)
' Write the corresponding value (in the same row)
' of the Source Lookup Range in the Source Value Array
' to the current element in the Destination Array.
dData(dr, 1) = svData(smrIndex, 1)
'Else ' not a match (resulting in an error value)
End If
' Else ' a blank: Empty, ="", ',...
End If
' Else ' any error value
End If
Next dr
' Create a reference to the Destination Value Range ('dvrg').
Dim dvrg As Range: Set dvrg = dlrg.EntireRow.Columns(dvCol)
' Write the (modified) values from the Destination Array
' to the Destination Value Range (in one go).
dvrg.Value = dData
' Save the workbook.
wb.Save
' Inform the user.
MsgBox "The lookup has finished successfully.", _
vbInformation, "Worksheet Caps"
ProcExit:
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
End Function
Please, try the next way:
If you need to place a formula to calculate Vlookup, use the next way:
cel.Offset(0, -1).Formula2 = "=Vlookup(" & cel.Address & ",Data!P2:Q110,2,False)"
You you need to calculate Vlookup in VBA, use the next alternative:
cel.Offset(0, -1).Value = WorksheetFunction.VLookup(cel.Value, Sheets("Data").Range("P2:Q110"), 2, False)
Edited:
Your whole code should should be adapted, in order to also deal with the case of no any match of VLookup function:
Private Sub Worksheet_Caps()
Dim SrchRng As Range, cel As Range, VLKresult
On Error Resume Next 'for the case of no any matched cells
Set SrchRng = Range("G31:G27").SpecialCells(xlCellTypeConstants) 'the range without empty cells
On Error GoTo 0
If Not SrchRng Is Nothing Then
For Each cel In SrchRng
VLKresult = Application.VLookup(cel.Value, Sheets("Data").Range("P$2:Q$110"), 2, False)
If Not IsError(VLKresult) Then
cel.Offset(0, -1).Value = VLKresult
Else
cel.Offset(0, -1).Value = "N/A"
End If
Next
End If
End Sub