so I have two ranges set in two codes. My problem is, the range is specific. No matter how much I changed it, I end up getting an error. My goal is to set the range from C1 all the way until the data stops (same for column J). The range varies depending which spreadsheet I have open so I would like it to detect the end of the data and stop there. Each cell will ALWAYS have data so you don't have to worry about empty cells in between.
Here is my code:
Sub Condition()
Set Rng = Range("C1:C1822")
For Each cell In Rng
If cell.Value <> "SB" Then
cell.Offset(0, 8).Value = "Introduced by Assemblymember"
Else
cell.Offset(0, 8).Value = "Introduced by Senator"
End If
Next
End Sub
'CORRECT LOWER CASE THEN UPPER CASE FIRST LETTER AND OFFSET TO NEW COLUMN
Sub Change()
Dim Rng As Range
Dim c As Range
Set Rng = ActiveSheet.Range("J1:J1822")
For Each c In Rng
c.Offset(, 2).Value = LCase(c.Value)
Next c
For Each cell In Application.ActiveSheet.UsedRange
If (cell.Value <> "") Then
cell.Value = UCase(Left(cell.Value, 1)) & Right(cell.Value, Len(cell.Value) - 1)
End If
Next
End Sub
My problem relies in the beginning at:
Sub Condition()
Set Rng = Range("C1:C1822")
For Each cell In Rng
and later shows up again at:
Sub Change()
Dim Rng As Range
Dim c As Range
Set Rng = ActiveSheet.Range("J1:J1822")
For Each c In Rng
c.Offset(, 2).Value = LCase(c.Value)
Next c
For Each cell In Application.ActiveSheet.UsedRange
If (cell.Value <> "") Then
cell.Value = UCase(Left(cell.Value, 1)) & Right(cell.Value, Len(cell.Value) - 1)
End If
Something like this will adjust to the number of populated rows:
Dim sht as WorkSheet, Rng As Range
Set sht = ActiveSheet
Set Rng = sht.Range(sht.Range("C1"), sht.Cells(sht.Rows.Count,"C").End(xlUp))
Related
The below code looks for duplicates in Column A, and if a duplicate exists, it sets the adjacent cell in column H to 0.
I've been trying to amend it to look for duplicates in column A as well as E, then if both are duplicates it will set the adjacent cell in column H to 0.
Would appreciate any help.
Dim Cell As Range
Dim DSO As Object
Dim Rng As Range
Set Rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
Set DSO = CreateObject("Scripting.Dictionary")
DSO.CompareMode = 1
For Each Cell In Rng
If DSO.Exists(Cell.Text) Then
Cell.Offset(0, 7) = 0
Else
DSO.Add Cell.Text, Cell
End If
Next Cell
Set DSO = Nothing
End Sub
You could do something like this:
Sub Dups()
Dim ws As Worksheet, DSO As Object, Cell As Range, k
Set DSO = CreateObject("Scripting.Dictionary")
DSO.CompareMode = 1 'case-insensitive
Set ws = ActiveSheet 'or some other sheet...
For Each Cell In ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp)).Cells
k = Cell.Value & Chr(0) & Cell.EntireRow.Columns("E").Value 'create the key value
If DSO.exists(k) Then
Cell.EntireRow.Columns("H").Value = 0
Else
DSO.Add k, Cell '.Value ?
End If
Next Cell
End Sub
I just added a second dictionary and checked both:
Sub CheckDupes()
Dim Cell As Range
Dim DSO1 As Object
Dim DSO2 As Object
Dim Rng As Range
Set Rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
Set DSO1 = CreateObject("Scripting.Dictionary")
DSO1.CompareMode = 1
Set DSO2 = CreateObject("Scripting.Dictionary")
DSO1.CompareMode = 1
For Each Cell In Rng
If DSO1.Exists(Cell.Text) And DSO2.Exists(Cell.Offset(0, 4).Text) Then
Cell.Offset(0, 7) = 0
Else
If Not DSO1.Exists(Cell.Text) Then _
DSO1.Add Cell.Text, Cell
If Not DSO2.Exists(Cell.Offset(0, 4).Text) Then _
DSO2.Add Cell.Offset(0, 4).Text, Cell.Offset(0, 4)
End If
Next Cell
Set DSO1 = Nothing
Set DSO2 = Nothing
End Sub
Example:
I'm trying to write the VBA so that in range H14:J16, for each row, if the Option Button in the left column is checked then cell.Offset(0,4).value=[a formula]; if option button in the middle column is checked then cell.Offset(0,3).value=[another formula]; if option button in the right column is checked then cell.Offset(0,2).value = [another formula]
I'm fairly new to VBA so am trying to piece together what I can and have come up with this so far:
Sub ServingSize()
Dim rng As Range, cell As Range
Set rng = Range("H14:J16")
Dim rng1 As Range, cell1 As Range
Set rng1 = Range("H14:H16")
Dim rng2 As Range, cell2 As Range
Set rng2 = Range("I14:I16")
Dim rng3 As Range, cell3 As Range
Set rng3 = Range("J14:J16")
For Each cell In rng
If Range("rng1").cell1.OptionButton = True Then
cell.Offset(0, 4).Value = cell.Offset(0, 3).Value * 0.5
ElseIf Range("rng2").cell2.OptionButton = True Then
cell.Offset(0, 3).Value = cell.Offset(0, 2).Value
ElseIf Range("rng3").cell3.OptionButton = True Then
cell.Offset(0, 2).Value = cell.Offset(0, 1).Value * 1.5
End If
Next cell
End Sub
What did i do wrong here?
You have to link a cell to each optionbutton, open the properties for the button , find the LinkedCell property and input the cell below the optionButton (it can be any other but for simplicity let's use the one located below the option button).
Then you use your code with modifications to test the linked cell value
Sub ServingSize()
Dim rng As Range, cell As Range
Set rng = Range("H14:J16")
Dim rng1 As Range, cell1 As Range
Set rng1 = Range("H14:H16")
Dim rng2 As Range, cell2 As Range
Set rng2 = Range("I14:I16")
Dim rng3 As Range, cell3 As Range
Set rng3 = Range("J14:J16")
For Each cell In rng
If cell = True Then
cell.Offset(0, 4).Value = cell.Offset(0, 3).Value * 0.5
end if
Next cell
'repeat the loop for each range of linked cells with the particular formula for End Sub
I want to select only cells that contains data in specific range (C7:I15). Code below can do that only for column "G". How to change code for my range?
Sub Testa()
Dim LR As Long, cell As Range, rng As Range
With Sheets("Sheet1")
LR = .Range("G" & Rows.Count).End(xlUp).Row
For Each cell In .Range("G2:G" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell
Else
Set rng = Union(rng, cell)
End If
End If
Next cell
rng.Select
End With
End Sub
You can use a generic function to which you pass the range that should be checked - and which returns a range with the non-empty cells (see update below for function using SpecialCells instead of iteration)
Public Function rgCellsWithContent(rgToCheck As Range) As Range
Dim cell As Range
For Each cell In rgToCheck
If cell.Value <> "" Then
If rgCellsWithContent Is Nothing Then
Set rgCellsWithContent = cell
Else
Set rgCellsWithContent = Union(rgCellsWithContent, cell)
End If
End If
Next cell
End Function
You can use this sub like this:
Sub Testa()
With ThisWorkbook.Worksheets("Sheet1")
'select cells in range C7:I15
rgCellsWithContent(.Range("C7:I15")).Select
'select cells in column G
Dim LR As Long
LR = .Range("G" & Rows.Count).End(xlUp).Row
rgCellsWithContent(.Range("G2:G" & LR)).Select
'you can even combine both
Dim rgNew As Range
Set rgNew = rgCellsWithContent(.Range("C7:I15"))
Set rgNew = Union(rgNew, rgCellsWithContent(.Range("G2:G" & LR)))
rgNew.Select
End With
End Sub
UPDATE:
This function uses the SpecialCells command.
You can make a difference to return values only or to return values and formulas.
Public Function rgCellsWithContent(rgToCheck As Range, _
Optional fValuesAndFormulas As Boolean = True) As Range
Dim cell As Range
On Error Resume Next 'in case there are no cells
With rgToCheck
Set rgCellsWithContent = .SpecialCells(xlCellTypeConstants)
If fValuesAndFormulas Then
Set rgCellsWithContent = Union(rgCellsWithContent, .SpecialCells(xlCellTypeFormulas))
End If
End With
On Error GoTo 0
End Function
If no formulas in the range where selection should be done, you can use the next compact code, not needing any iteration:
Dim rng As Range
On Error Resume Next 'for the case of no any empty cell
Set rng = Range("C7:I15").SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rng Is Nothing Then rng.Select
The next version is able to deal with formulas, too:
Dim rng As Range, rngSel As Range, arrFormula
Set rng = Range("C7:I15")
With rng
arrFormula = .Formula
.Value = .Value
On Error Resume Next
Set rngSel = .SpecialCells(xlCellTypeConstants)
On Error GoTo 0
.Formula = arrFormula
End With
If Not rngSel Is Nothing Then rngSel.Select
I want to develop a macro to check if values from one column in a sheet are found as substrings in the columns of another sheet.
So, I want to check each cell of my first column, and if it's not empty, compare it to every cell in the second sheet, of columns 1 and 3.
For this I used a "for each" loop, and then a "for" loop, with i from 1 to Rows.Count.
This is where it gets tricky as I'm not sure if it's the right way to approach this. Also, the parameters of the instr() function to check if values are found as substrings don't seem to match, as I get a "type mismatch" error when trying to run the code.
Sub test()
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")
Dim i As Long
Dim rng As Range, cell As Range
Set rng = Wks1.Range("C3:O69")
For Each cell In rng
If Not (IsEmpty(cell.Value)) Then
For i = 1 To Wks2.Rows.Count
If (InStr(Cells(i, 1), cell.Value, 1) <> 0) Or (InStr(Cells(i, 3), _
cell.Value, 1) <> 0) Then
Cells(i, 4) = "String contains substring"
End If
Next i
End If
Next cell
End Sub
That should work
Sub test()
Dim i As Long
Dim rng As Range, cell As Range
Dim lastRow as Long
Set Wks1 = Worksheets("Sheet1")
Set Wks2 = Worksheets("Sheet2")
Set rng = Wks1.Range("C3:O69")
lastRow = Wks2.Cells(Rows.Count, 1).End(xlUp).row
For Each cell In rng
If Not (IsEmpty(cell.Value)) Then
For i = 1 To lastRow
With Wks2
If (InStr(.Cells(i, 1), cell.Value) <> 0) Or (InStr(.Cells(i, 3), cell.Value) <> 0) Then
.Cells(i, 4) = "String contains substring"
End If
End With
Next i
End If
Next cell
End Sub
Sub NSV_LINK()
Dim cell As Range
Dim Rng As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each cell In Rng
If cell.Value = "Hemanta" Then cell.EntireRow.Copy Sheets(2).Cells(1, 1)
Next cell
End Sub
In the code above, I want the macro to copy and paste values in successive rows in sheet 2. However, I have hard coded the destination cell i.e, the value gets pasted at A1. How do I write the cell destination, so that the values get pasted in successive rows? Cells(i, 1)...Something like this. And then i takes a range from, let's say 1 to 20. How do I write this in code?
you need a counter and you have to increment it
Sub NSV_LINK()
Dim cell As Range, Rng As Range, r As Long
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
r = 1
For Each cell In Rng
If cell.Value = "Hemanta" Then
cell.EntireRow.Copy Sheets(2).Cells(r, 1)
r = r + 1
End If
Next cell
End Sub
you can adapt the same technique you already used in Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)) to make destination range dynamic:
Sub NSV_LINK()
Dim cell As Range, Rng As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
For Each cell In Rng
If cell.Value = "Hemanta" Then cell.EntireRow.Copy Sheets(2).Cells(Rows.Count, 1).End(xlUp).Offset(1) ' make destination range dynamic to target sheeet column A first not empty cell after last not empty one
Next cell
End Sub