Below is my code. What i want is the code should ignore the case of alphabets whether it is small capital or both.
Private Sub CommandButton1_Click()
Dim ws As Worksheet, tbl As ListObject, row As ListRow
Set ws = Sheets("Sheet1")
Set tbl = ws.ListObjects("Table2")
Dim intValueToFind As String, intValueToFind1 As String, rng As Range, rng1 As Range
Set rng = tbl.ListColumns(1).DataBodyRange
Set rng1 = tbl.ListColumns(2).DataBodyRange
intValueToFind = LCase(Me.ComboBox1.Value)
intValueToFind1 = LCase(Me.TextBox2.Value)
If Not rng Is Nothing Then
For Each rng In rng
If LCase(rng.Value) = intValueToFind Then
If Not rng1 Is Nothing Then
For Each rng1 In rng1
If LCase(rng1.Value) = intValueToFind1 Then
MsgBox ("Group Head under this Account Head already Exist. Please enter the Unique Name...")
Exit Sub
End If
Next rng1
End If
End If
Next rng
End If
Set row = tbl.ListRows.Add
row.Range(1, 1).Value = Me.ComboBox1.Value
row.Range(1, 2).Value = Me.TextBox2.Value
End Sub
kindly review the above code and advise where i am mistaking.
Just cast both sides to lower case (or upper case):
If LCase(rng.Value) = LCase(intValueToFind) Then
Related
I've written a code that does many things. Essentially it loops through each worksheets starting with MW, in these sheets, it deletes some columns, does some operations and changes some column names. Right now, The code works, but after adding the loop through worksheets, I get an error 424 on the "If not Rng Is Nothing Then Rng.EntireColumn.Delete"
How can I fix this?
My theory is that my ws loop doesn't work well, so the code can't work since the sheet is already processed
Here's my code
Dim Cl As Range, Rng As Range
Dim Cl2 As Range, Rng2 As Range
Dim Cl3 As Range, Rng3 As Range
Dim c As Range
Dim Cl4 As Range, Rng4 As Range
Dim Lastrow As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If ws.Name Like "MW*" Then
For Each Cl In Range("A1:J1")
Select Case Cl.Value
Case "#", "Coupler Detached", "Coupler Attached", "Host Connected", "End Of File", "ms"
If Rng Is Nothing Then Set Rng = Cl Else Set Rng = Union(Rng, Cl)
End Select
Next Cl
If Not Rng Is Nothing Then Rng.EntireColumn.Delete
For Each Cl4 In Range("D1")
Select Case Cl4.Value
Case "Abs Pres (kPa) c:1 2"
If Rng4 Is Nothing Then Set Rng4 = Cl4 Else Set Rng4 = Union(Rng4, Cl4)
End Select
Next Cl4
If Not Rng4 Is Nothing Then
Application.ScreenUpdating = False
Lastrow = Cells(Rows.Count, "D").End(xlUp).Row
For Each c In Range("D2:D" & Lastrow)
c.Value = c.Value * 0.101972
Next
Application.ScreenUpdating = True
End If
For Each Cl2 In Range("A1:J1")
Select Case Cl2.Value
Case "Abs Pres (kPa) c:1 2"
If Rng2 Is Nothing Then Set Rng2 = Cl2 Else Set Rng = Union(Rng, Cl2)
End Select
Next Cl2
If Not Rng2 Is Nothing Then Rng2.Value = ("LEVEL")
For Each Cl3 In Range("A1:J1")
Select Case Cl3.Value
Case "Temp (°C) c:2"
If Rng3 Is Nothing Then Set Rng3 = Cl3 Else Set Rng = Union(Rng, Cl3)
End Select
Next Cl3
If Not Rng3 Is Nothing Then Rng3.Value = ("TEMPERATURE")
End If
Next ws
Object Variables in Loops
The main issue was that you cannot combine cells with an invalid range so you need to 'reset' the rng* variables i.e. explicitly set them to nothing. For example, in the first iteration, there were cells combined into rng. Now you delete rng and the variable's state is still Not Nothing although you have deleted the range making it invalid. In the next iteration, you try to combine this invalid range (which is Not Nothing) with a matching cell via Union so the error occurs. BTW, even if you didn't delete the range, again, an error would occur because you cannot combine ranges from different worksheets.
In the following code, pay attention to how this (Set rng = Nothing) is done after each stage per worksheet when only a single rng variable is used.
Also, note how ws and cell are 'safe', they don't need to be reset, since For Each... could be translated as something like Set ws = WhatEverWorksheet or Set cell = WhatEverCell.
Sub ALot()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' If it's not, change back to 'ActiveWorkbook'.
Application.ScreenUpdating = False
Dim ws As Worksheet, rng As Range, cell As Range
For Each ws In wb.Worksheets
If ws.Name Like "MW*" Then
' Delete columns.
For Each cell In ws.Range("A1:J1").Cells
Select Case CStr(cell.Value)
Case "#", "Coupler Detached", "Coupler Attached", _
"Host Connected", "End Of File", "ms"
If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell)
End Select
Next cell
If Not rng Is Nothing Then
rng.EntireColumn.Delete
Set rng = Nothing ' reset
End If
' Check 4th column.
Set cell = ws.Range("D1")
If CStr(cell.Value) = "Abs Pres (kPa) c:1 2" Then
Set rng = ws.Range("D2", ws.Cells(ws.Rows.Count, "D").End(xlUp))
rng.Value = ws.Evaluate(rng.Address & "*0.101972")
Set rng = Nothing ' reset
End If
' Check "Abs Pres (kPa) c:1 2".
For Each cell In ws.Range("A1:J1").Cells
Select Case CStr(cell.Value)
Case "Abs Pres (kPa) c:1 2"
If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell)
End Select
Next cell
If Not rng Is Nothing Then
rng.Value = "LEVEL"
Set rng = Nothing ' reset
End If
' Check "Temp (°C) c:2".
For Each cell In ws.Range("A1:J1").Cells
Select Case cell.Value
Case "Temp (°C) c:2"
If rng Is Nothing Then Set rng = cell Else Set rng = Union(rng, cell)
End Select
Next cell
If Not rng Is Nothing Then
rng.Value = "TEMPERATURE"
Set rng = Nothing ' reset
End If
'Else ' is not like "MW*"; do nothing
End If
Next ws
Application.ScreenUpdating = True
MsgBox "Worksheets processed.", vbInformation
End Sub
Looking for a simple loop through the range (say column A range("A5:A15")) if there is a blank cell within that range I need the entire row/rows associated with the blank cell/cells to be hidden.
I was thinking of something like this to accommodate various ranges but get "type Mismatch" error. Any reasons why
Sub test()
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
For Each cell In MyArray
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next cell
End With
End Sub
?
Something Like this:
You can put it in a subject:
For Each cell In Range("A5:A15")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
For Each cell In Range("A40:A55")
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
New Answer :
Dim rng As Range, cell As Variant, ar As Variant
Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range
Dim MyArray(1 To 4) As Range
With ThisWorkbook.Worksheets("sheet1")
'Set MyArray = rng
Set MyArray(1) = Range("O8:O17")
Set MyArray(2) = Range("O55:O64")
Set MyArray(3) = Range("G37:G46")
Set MyArray(4) = Range("G89:G98")
'ar = Array(Rng1, Rng2, Rng3, Rng4)
'Set rng = .Range("O8:O17")
Dim i As Integer
For i = LBound(MyArray) To UBound(MyArray)
For Each cell In MyArray(i)
If Len(cell.Value) < 1 Then
cell.EntireRow.Hidden = True
End If
Next
Next
End With
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .Range("A5:A15")
For Each cell In rng
If cell.Value = "" Then
.Rows(cell.Row).EntireRow.Hidden = True
End If
Next cell
End With
End Sub
This takes full advantage of the Excel VBA model. I'm guessing it's faster than the above but have not conducted performance tests.
Dim Cell As Range
For Each Cell In Range("A5:A15").SpecialCells(xlCellTypeBlanks)
Cell.EntireRow.Hidden = True
Next
Try the following
Option Explicit
Sub youcouldhaveatleasttriedtodosomethingyourself()
Dim r1 As Range, r2 As Range, c As Range, target As Range
With Workbooks(REF).Sheets(REF)
Set r1 = .Range("A1:A54")
Set r2 = .Range("F3:F32")
Set target = Application.Union(r1, r2)
For Each area In target.Areas
For Each c In area
If c.Value = vbNullString Then .Rows(c.Row).EntireRow.Hidden = True
Next c
Next area
End With
End Sub
Please note that I now have set two exemplifying ranges. You can always add more range variables to the Union function.
I am trying to write a UDF that will Move or Delete all columns in an array
This part I have.
I also want to Delete or Move all columns not in the array and this part I am stuck on.
This is Case 2 and 4 of the function
Any help on this is appreciated
Thanks
Edit: Updated with answer provided by David G
Function InvertRng(shtName As String, r As Range) As Range
Dim rng As Range
Dim Rng1 As Range, Rng2 As Range
Set Rng1 = GetUsedRange(shtName, 1, True)
For Each rng In Rng1
If Application.Intersect(rng, r) Is Nothing Then
If InvertRng Is Nothing Then
Set InvertRng = rng
Else
Set InvertRng = Application.Union(InvertRng, rng)
End If
End If
Next
End Function
Original Question
Sub MoveOrDelete_n()
MoveOrDelete 2, "Elements", "NewSheet", Array("Id", "Type", "Description")
End Sub
The Function
Function MoveOrDelete(iwhat As Long, SshtName As String, TshtName As String, arrHeaders As Variant) 'Excel VBA to move Columns based on criteria
Dim wsS As Worksheet, wsT As Worksheet
Dim ar As Variant
Dim fn As Range, r As Range
Dim str As String
Dim i As Long
Set wsS = ThisWorkbook.Sheets(SshtName)
Set wsT = ThisWorkbook.Sheets(TshtName)
For i = 0 To UBound(arrHeaders) 'Loop through the Array
Set fn = wsS.Rows("1:1").Find(arrHeaders(i), LookAt:=xlWhole)
str = str & fn.Address & ","
Next i
'Remove the trailing comma from the string
str = Left(str, Len(str) - 1)
Set r = wsS.Range(str).EntireColumn
Select Case iwhat
Case 1
'Delete all columns IN list
r.Delete
Case 2
'Delete all columns NOT in list
invertR.Delete
Case 3
'Move all columns IN List to NEW Sheet
r.Copy wsT.[a1]
Case 4
'Move all columns NOT in List to NEW SheeT
invertR.Copy wsT.[a1]
End Select
End Function
I found this function that invert the selection, maybe is what you need:
Sub InvertSelection()
'Updateby20140314
Dim rng As Range
Dim Rng1 As Range
Dim Rng2 As Range
Dim OutRng As Range
xTitleId = "KutoolsforExcel"
Set Rng1 = Application.Selection
Set Rng1 = Application.InputBox("Range1 :", xTitleId, Rng1.Address, Type:=8)
Set Rng2 = Application.InputBox("Range2", xTitleId, Type:=8)
For Each rng In Rng2
If Application.Intersect(rng, Rng1) Is Nothing Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
OutRng.Select
End Sub
https://www.extendoffice.com/documents/excel/762-excel-reverse-selections.html
I am trying to insert a new row into a named range. The user selects a "category" from a combo box e.g., Cool Drinks, Beer and Cider, Bitters etc... and then the contents of that category populate another combo box.
I have named the ranges of all of the Categories and would like them to populate the second combo box. I have a code which works by itself:
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
However, whenever I try to use that in a Select Case, it doesn't work.
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
Does anybody have any ideas?
Here is the complete code:
Option Explicit
Private Sub UserForm_Initialize()
'InitializeTypeCombo
Dim Types() As String
Types = Split("Cool Drinks,Beer and
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,Red Wine",
",")
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
'InitializeNameCombo
Dim rng As Range
Dim DailySales As Worksheet
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
Private Sub CmdExit_Click()
Unload Me
End Sub
Private Sub CmdEnter_Click()
Dim rng As Range
'Store Date Index
Dim colArray(32) As Integer
'Store Item Index
Dim rowArray(150) As Integer
'Store first value for Find and FindNext
Dim FirstAddress As String
Dim i As Integer
Dim j As Integer
i = 0
j = 0
With Range("B6:AD6")
Set rng = .Find(TxtDate.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
colArray(i) = rng.Column
i = i + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
With Range("A7:A150")
Set rng = .Find(CmboName.Value, LookIn:=xlValues)
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
Set rng = .FindNext(rng)
rowArray(j) = rng.Row
j = j + 1
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
End With
Dim c As Integer
Dim r As Integer
For c = 0 To i - 1
For r = 0 To j - 1
Cells(rowArray(r), colArray(c)).Value = TxtNoSold.Value
Next r
Next c
Unload Me
End Sub
The solution was simply moving the Select Case into the Combobox_Change event. As Dick Kusleika said, the value of the combobox was nothing at runtime. Here is the correct code to accomplish what I was trying to do.
Option Explicit
Private Sub Userform_Initialize()
'Populate cmboTypes
Dim Types() As String
Types = Split("Cool Drinks,Beer and _
Cider,Bitters,Brandy,Whiskey,Rum,Spirits,Sherry,White Wine,_
Red Wine", ",")
'Loop through the values populated in the split function above, and add
'each item to the combobox
Dim i As Integer
For i = LBound(Types) To UBound(Types)
Me.CmboType.AddItem Types(i)
Next
End Sub
Sub CmboType_Change()
Dim rng As Range
Dim DailySales As Worksheet
'Populate CmboName with named dynamic ranges of "Types"
Set DailySales = Worksheets("Daily Sales")
Select Case Me.CmboType.Value
Case "Cool Drinks"
Set rng = DailySales.Range("CoolDrinksDailySales")
For Each rng In DailySales.Range("CoolDrinksDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Beer and Cider"
CmboName.Clear
Set rng = DailySales.Range("BeerCiderDailySales")
For Each rng In DailySales.Range("BeerCiderDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Bitters"
CmboName.Clear
Set rng = DailySales.Range("BittersDailySales")
For Each rng In DailySales.Range("BittersDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Brandy"
CmboName.Clear
Set rng = DailySales.Range("BrandyDailySales")
For Each rng In DailySales.Range("BrandyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
Case "Whiskey"
CmboName.Clear
Set rng = DailySales.Range("WhiskeyDailySales")
For Each rng In DailySales.Range("WhiskeyDailySales")
Me.CmboName.AddItem rng.Value
Next rng
End Select
End Sub
I have a workbook with two sheets. On Sheet A, I have changed the interior color of some cells. I would like to find cells in Sheet B with matching text and set them to have the same interior color. However, when I get to hRow = Application..., I receive an error that The application does not support this object or property. I've been searching for similar functions, but I am not having any success finding a good way to match text without looping through each cell in a range.
Public Sub MatchHighlight()
Dim lRow As Integer
Dim i As Integer
Dim hRow As Integer
Dim LookUpRange As Range
Set LookUpRange = Worksheets("HR - Highlight").Range("C2:C104")
Dim compare As Range
Set compare = Worksheets("Full List").Range("C2:C277")
lRow = Worksheets("Full List").UsedRange.Rows.Count
For i = 2 To lRow
hRow = Application.Worksheets("Full List").WorksheetFunction.Match(compare.Range("C" & i).Text, LookUpRange, 0)
If Not IsNull(hRow) Then
compare.Range("C" & i).Interior.Color = LookUpRange.Range("C" & hRow).Interior.Color
End If
Next i
End Sub
Sub MatchHighlight()
Dim wsHighlight As Worksheet
Dim wsData As Worksheet
Dim rngColor As Range
Dim rngFound As Range
Dim KeywordCell As Range
Dim strFirst As String
Set wsHighlight = Sheets("HR - Highlight")
Set wsData = Sheets("Full List")
With wsData.Columns("C")
For Each KeywordCell In wsHighlight.Range("C2", wsHighlight.Cells(Rows.Count, "C").End(xlUp)).Cells
Set rngFound = .Find(KeywordCell.Text, .Cells(.Cells.Count), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Set rngColor = rngFound
Do
Set rngColor = Union(rngColor, rngFound)
Set rngFound = .Find(KeywordCell.Text, rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
rngColor.Interior.Color = KeywordCell.Interior.Color
End If
Next KeywordCell
End With
End Sub
To get exactly what I wanted, I used #tigeravatar's code as a base and ended up with the following:
Sub MatchHighlight()
Dim wsHighlight As Worksheet
Dim wsData As Worksheet
Dim rngColor As Range
Dim rngFound As Range
Dim KeywordCell As Range
Dim strFirst As String
Dim rngPicked As Range
Set rngPicked = Application.InputBox("Select Cell", Type:=8)
Set wsHighlight = Sheets("HR - Highlight")
Set wsData = Sheets("Full List")
With wsData.Columns("C")
For Each KeywordCell In wsHighlight.Range("C2", wsHighlight.Cells(Rows.Count, "C").End(xlUp)).Cells
Set rngFound = .Find(KeywordCell.Text, .Cells(.Cells.Count), xlValues, xlWhole)
If Not rngFound Is Nothing Then
strFirst = rngFound.Address
Set rngColor = rngFound
Do
Set rngColor = Union(rngColor, rngFound)
Set rngFound = .Find(KeywordCell.Text, rngFound, xlValues, xlWhole)
Loop While rngFound.Address <> strFirst
Set rngColor = rngColor.Offset(0, -2).Resize(1, 3)
If KeywordCell.Interior.Color = rngPicked.Interior.Color Then
rngColor.Interior.Color = KeywordCell.Interior.Color
End If
End If
Next KeywordCell
End With
End Sub
Only real differences are that I let the user pick the color of cells they're trying to match, I only change the interior color when it matches the color picked, and I change the color of the whole row.
This can be done much much faster with:
Option Explicit
Sub MatchHighlight()
Dim FullListCell As Range
Dim HighlightMasterCell As Range
Dim FullList As Range
Dim HighlightMaster As Range
Dim lastRow As Range
'find last row in FullList
Set lastRow = Range("C").End(xlDown)
Set HighlightMaster = ThisWorkbook.Sheets("kleuren_medewerkers").Range("A1:A100")
Set FullList = Range(Range("C2"), ActiveSheet.Cells(lastRow.Row, 3)) 'change the number 3 to include more columns but use the lastrow of column C
For Each HighlightMasterCell In HighlightMaster
For Each FullListCell In FullList
If FullListCell .Value = HighlightMasterCell.Value Then
FullListCell.Interior.Color= HighlightMasterCell.Interior.Color
End If
Next
Next
End Sub