I am pretty new to vba and I am facing a problem I couldn't find a solution to so far. I have two lists of names in the worksheet "Source" that I want to use for a for each loop. How can I address those cells by using the correct Worksheet?
I want to access combo boxes that are named "Boxvariablename" (e.g. BoxIAA) and associated text boxes in the form "variablenamevalue" (e.g. IAAvalue) and check the content of all these objects, deleting the two cells to the right (e.g. D3:E3 or G5:H5) in the worksheet "Source" if the objects are empty.
My attempt was:
Dim rng As Range, cell As Range
Set rng = Range(Sheets("Source").Range("C2:C4"), Sheets("Source").Range("F2:F5"))
For Each cell In rng
If "Box" & cell.Value <> "" Then
MsgBox "The value is " & "Box" & Range(cell).Value
Else If
'Delete two cells to the right in ws "Source"
End If
Next cell
I am aware, that I am not addressing the Cells C2:C4 in the worksheet Source correctly, but I really don't know how to do it properly.
How can I access the content of the source cells and address the content / the cells for later use?
Is this what you are trying (untested)?
Sub Sample()
Dim rng As Range
Dim aCell As Range
On Error GoTo Whoa '<~~ Need this in case it couldn't find the control
Set rng = Sheets("Source").Range("C2:C4,F2:F5")
For Each aCell In rng
'~~> Use Controls() to work with the control
With Me.Controls("Box" & aCell.Value)
If .Value <> "" Then
MsgBox .Value
Else
'~~> Do what you want
Sheets("Source").Range(aCell.Offset(, 1), _
aCell.Offset(, 2)).Delete shift:=xlLeft
End If
End With
Next aCell
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Instead of If .Value <> "" Then you can also use If .ListIndex <> -1 Then. I am assuming that there are no blank values in the combobox.
Related
I have a spreadsheet with 4 sheets that I need to run a vba macro that will search through column Y & D and delete any rows that contain data that has the word "test" somewhere in it. Not case sensitive, so it could be TEST, test, TesT, etc.
Can someone help me draft up some code for that.
What i've got so far. It doesn't work if there is other words combined with test.
And i'd have to make two macros and then run macro one and have macro two run after macro1. Preferably i'd like to just have one script of VBA if that were possible.
Sub DeleteRowswithSpecificValue()
Dim cell As Range
For Each cell In Range("D:D99999")
If cell.Value = "delete" Then
cell.EntireRow.Delete
End If
Next cell
End Sub
This should get you what you need. Important to conduct the delete after each worksheet loop as that will optimize performance.
Sub deleteAllTest()
Const textToDelete As String = "test"
Dim ws As Worksheet, aCell As Range, killRange As Range
For Each ws In ThisWorkbook.Worksheets
Set killRange = Nothing
For Each aCell In Intersect(ws.Range("Y:Y"), ws.UsedRange).Cells
If InStr(1, aCell.Value2 & ws.Cells(aCell.Row, 4).Value, textToDelete, vbTextCompare) > 0 Then
If killRange Is Nothing Then
Set killRange = aCell.EntireRow
Else
Set killRange = Union(aCell.EntireRow, killRange)
End If
End If
Next aCell
If Not killRange Is Nothing Then killRange.Delete
Next ws
End Sub
I have a workbook that includes duplicated headers and a page number that I want to remove via vba macro.
The below screenshot repeats itself throughout my workbook, I have tried to write a macro that finds the specific text and delete but causes the data to shift incorrectly and is wildly inefficient. The rows in between the headers are not always 3 so I can't have a macro that blindly deletes 5 rows every x rows. For clarity, I am trying to delete the bolded text while not losing the integrity of the unbolded data.
Is it possible to have a macro that goes over a specific range to delete the repeated headers and metadata depicted above?
Macro attempted to use from How to delete row based on cell value. Understandably changing the text for each header / metadata is not a reasonable solution and causes the data shift.
Sub DeleteRowsWithHyphen()
Dim rng As Range
For Each rng In Range("A2:A20") 'Range of values to loop through
If InStr(1, rng.Value, "Page 1 of 10") > 0 Then 'InStr returns an integer of the position, if above 0 - It contains the string
rng.Delete
End If
Next rng
End Sub
It looks like you can delete all rows that are not number in column. If so then try ..
Sub DeleteNonNumberRows()
Dim rng As Range, Cl As Range, DelRng As Range
LRow = Range("A" & Rows.Count).End(xlUp).Row
Set rng = Range("A1", "A" & LRow)
For Each Cl In rng
If IsNumeric(Cl) = False Or Cl = "" Then
If DelRng Is Nothing Then
Set DelRng = Cl
Else
Set DelRng = Union(DelRng, Cl)
End If
End If
Next
DelRng.EntireRow.Delete
End Sub
Note that rng is starting from A1. Change it as suitable.
If column G in workbook1 isn't empty, then copy that whole row to workbook2.
Now, the way I'd do it would simply be "Do Until" with an If statement inside.
I know that's probably far from the most efficient way of cracking this one, so I'm asking for help.
Rather than finding, copying and pasting for each cell, we first take the union of all the rows that match the given criterion, and then copy and paste just once. To use the solution below, make sure both workbooks are open and put their names in the strings below, as appropriate:
Sub Macro1()
Dim wb1s as Worksheet, wb2s as Worksheet, rngG As Range, MySel As Range
'Change String as required based on your Workbook Name
'Change Worksheet number as required.
Set wb1s = Workbooks("workbook1.xlsx").Worksheets(1)
Set wb2s = Workbooks("workbook2.xlsx").Worksheets(1)
With wb1s
Set rngG = .Range("G1", .Range("G" & .Rows.Count).End(xlUp))
End With
For Each cell In rngG
If cell.Value <> "" Then
If MySel Is Nothing Then
Set MySel = cell.EntireRow
Else
Set MySel = Union(MySel, cell.EntireRow)
End If
End If
Next cell
If Not MySel Is Nothing Then MySel.Copy Destination:= wb2s.Range("A1")
End Sub
I have two columns, Column (A) and Column (B) in a spreadsheet.
Column (A) contains names extracted from a query (ex. Brian, Bob, Bill, etc...) and column (B) contains one of three statuses (Assigned, In Progress, or Pending).
However, this query sometimes pulls up some line items showing "Assigned" for the status with no name, therefore corresponding cell representing the name in Column (A) is blank. So I manually fill in those empty cells with "Unknown".
What I want to do is to create a macro that finds the every empty cell in column (A) and fill in the word "Unknown" if the cell to its right contains the word "Assinged".
So the conditions are:
Blank cell in column (A)
Correspoding cell to its right (column B) contains the word "assinged"
This is my Code:
Private Sub CommandButton2_Click()
For Each cell In Columns("A")
If ActiveCell.Value = Empty And ActiveCell.Offset(0, 1).Value = "Assigned" Then ActiveCell.Value = "Unknown"
Next cell
End Sub
There is no need to loop here, take advantage of excels built in methods which will execute faster.
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
.AutoFilter Field:=1, Criteria1:=""
.AutoFilter Field:=2, Criteria1:="Assigned"
If WorksheetFunction.CountBlank(.Columns(1)) > 0 Then
If .Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
.Columns(1).SpecialCells(xlCellTypeBlanks).Value = "Unknown"
End If
End If
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Welcome to SO.
Try this code. It will work a bit faster and should get you what you want.
Update: Made the code more bullet proof!
Private Sub CommandButton2_Click()
Dim cel As Range, rngFind As Range, rngFilter As Range
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
'-> Error check to make sure "blanks" exist
Set rngFind = .Range("A1:A" & .Range("B" & Rows.Count).End(xlUp).Row).Find("", lookat:=xlWhole)
If Not rngFind Is Nothing Then
Set rngFilter = .Range("A1:B" & .Range("B" & Rows.Count).End(xlUp).Row)
rngFilter.AutoFilter 1, "="
'-> Error check to make sure "assigned" exists for blank cells
Set rngFind = .Columns("B:B").SpecialCells(xlCellTypeVisible).Find("Assigned", lookat:=xlWhole)
If Not rngFind Is Nothing Then
'-> okay, it exists. filter and loop through cells
rngFilter.AutoFilter 2, "Assigned"
Set rngFind = Intersect(.UsedRange, .UsedRange.Offset(1), .Columns(1)).SpecialCells(xlCellTypeVisible)
For Each cel In rngFind
If cel.Offset(0, 1).Value = "Assigned" Then cel.Value = "Unknown"
Next cel
End If
End If
End With
End Sub
If you only need to do this a few times you could
format your used range as a table
on column A filter to only show "(Blanks)"
on column B filter to only show "assinged"
select all the resulting cells in column B
press alt + : to select only the visible cells
press F2
type "unknown"
press ctrl + enter
Your bad data should be good now!
Obviously this is a non-vba based solution but if you can avoid coding it's probably for the best.
I want to test if a given cell is within a given range in Excel VBA. What is the best way to do this?
From the Help:
Set isect = Application.Intersect(Range("rg1"), Range("rg2"))
If isect Is Nothing Then
MsgBox "Ranges do not intersect"
Else
isect.Select
End If
If the two ranges to be tested (your given cell and your given range) are not in the same Worksheet, then Application.Intersect throws an error. Thus, a way to avoid it is with something like
Sub test_inters(rng1 As Range, rng2 As Range)
If (rng1.Parent.Name = rng2.Parent.Name) Then
Dim ints As Range
Set ints = Application.Intersect(rng1, rng2)
If (Not (ints Is Nothing)) Then
' Do your job
End If
End If
End Sub
Determine if a cell is within a range using VBA in Microsoft Excel:
From the linked site (maintaining credit to original submitter):
VBA macro tip contributed by Erlandsen Data Consulting
offering Microsoft Excel Application development, template customization,
support and training solutions
Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2
InRange = Not (Application.Intersect(Range1, Range2) Is Nothing)
End Function
Sub TestInRange()
If InRange(ActiveCell, Range("A1:D100")) Then
' code to handle that the active cell is within the right range
MsgBox "Active Cell In Range!"
Else
' code to handle that the active cell is not within the right range
MsgBox "Active Cell NOT In Range!"
End If
End Sub
#mywolfe02 gives a static range code so his inRange works fine but if you want to add dynamic range then use this one with inRange function of him.this works better with when you want to populate data to fix starting cell and last column is also fixed.
Sub DynamicRange()
Dim sht As Worksheet
Dim LastRow As Long
Dim StartCell As Range
Dim rng As Range
Set sht = Worksheets("xyz")
LastRow = sht.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
Set rng = Workbooks("Record.xlsm").Worksheets("xyz").Range(Cells(12, 2), Cells(LastRow, 12))
Debug.Print LastRow
If InRange(ActiveCell, rng) Then
' MsgBox "Active Cell In Range!"
Else
MsgBox "Please select the cell within the range!"
End If
End Sub
Here is another option to see if a cell exists inside a range. In case you have issues with the Intersect solution as I did.
If InStr(range("NamedRange").Address, range("IndividualCell").Address) > 0 Then
'The individual cell exists in the named range
Else
'The individual cell does not exist in the named range
End If
InStr is a VBA function that checks if a string exists within another string.
https://msdn.microsoft.com/en-us/vba/language-reference-vba/articles/instr-function
I don't work with contiguous ranges all the time. My solution for non-contiguous ranges is as follows (includes some code from other answers here):
Sub test_inters()
Dim rng1 As Range
Dim rng2 As Range
Dim inters As Range
Set rng2 = Worksheets("Gen2").Range("K7")
Set rng1 = ExcludeCell(Worksheets("Gen2").Range("K6:K8"), rng2)
If (rng2.Parent.name = rng1.Parent.name) Then
Dim ints As Range
MsgBox rng1.Address & vbCrLf _
& rng2.Address & vbCrLf _
For Each cell In rng1
MsgBox cell.Address
Set ints = Application.Intersect(cell, rng2)
If (Not (ints Is Nothing)) Then
MsgBox "Yes intersection"
Else
MsgBox "No intersection"
End If
Next cell
End If
End Sub