Looking for a little assistance with a code I'm attempting to right.
The Result should be that when a user clicks a button on a userform named "Btn_LaSearch" that all columns in a range E6:MB6 are hidden except for the column where the name in the range matches that in a combobox on the userform.
the code i have so far looks like this...
Private Sub Btn_LASearch_Click()
Range("A1").Select
ActiveCell.Value = Cbo_LocalList.Value
Dim rngFound As Range
Dim Target As String
If Target.Address(0, 0) = "A1" Then
Application.ScreenUpdating = False
With Range("E6:MB6")
.EntireColumn.Hidden = False
If Target <> "" Then
Set rngFound = .Cells.Find(Target, , , xlWhole, , xlNext, False)
If Not rngFound Is Nothing Then
.EntireColumn.Hidden = True
rngFound.EntireColumn.Hidden = False
End If
End If
End With
Application.ScreenUpdating = True
End If
End Sub
I keep getting a Compile Error: Invalid Qualifier and it highlights this row.
If Target.Address(0, 0) = "A1" Then
I'm still very much an amateur when it comes to VBA so all help is appreciated.
Kind Regards,
I'm not sure why you're pasting the name into A1, then using that on a search when you already have access to the name.
Try something like this:
Private Sub Btn_LASearch_Click()
Dim c as Range
Application.ScreenUpdating = False
For Each c In Range("E6:MB6")
c.EntireColumn.Hidden = Not (c.Value = Cbo_LocalList.Value)
Next
Application.ScreenUpdating = True
End Sub
Related
I have a userform with a combobox on a sheet "PostHistory" that draws it's data from the "Staff" sheet. When you press Add on the userform it's suppose to locate the name on the Staff Sheet and replace the date next to the name. Occasionally, it will replace the date and the date next to the name below it. Using Excel 2016
Private Sub CommandButton7_Click()
Application.ScreenUpdating = False
Sheets("Staff").Visible = True
Sheets("Engine").Visible = True
Dim TargetRow As Integer
Dim nameRange As Range
Set nameRange = Sheets("Staff").Range("C3:C200")
TargetRow = Sheets("Engine").Range("D3").Value
Sheets("PostHistory").Range("B3").EntireRow.Insert Shift:=xlDown
Sheets("PostHistory").Range("B3").Value = txt_date
Sheets("PostHistory").Range("C3").Value = cb_staff
Sheets("PostHistory").Range("D3").Value = txt_post
Sheets("PostHistory").Range("E3").Value = txt_notes
If (Augment.txt_date.Text) = "" Then
GoTo Skip1
ElseIf IsNull(Augment.txt_date.Value) = False Then
End If
For Each cell In nameRange.Cells
If cell.Text = [cb_staff] Then
cell.Offset(0, -1).Value = txt_date
End If
Next
Skip1:
Unload Augment
Sheets("Staff").Visible = False
Sheets("Engine").Visible = False
Sheets("List").Visible = False
Application.ScreenUpdating = True
Augment.Show
End Sub
To start: I didn't find the reason why your code should write more than once. But I believe the code below will not write anything twice.
Private Sub CommandButton7_Click()
' 209
Dim nameRange As Range
Dim Fnd As Range
Dim Ctls() As String
Dim i As Integer
Ctls = Split("txt_Date,cb_Staff,txt_Post,txt_Notes", ",")
If Len(txt_Date) Then
With Worksheets("Staff")
Set nameRange = .Range(.Cells(3, 3), .Cells(.Rows.Count, 3).End(xlUp))
End With
Set Fnd = nameRange.Find(cb_Staff.Value, , xlValues, xlWhole)
If Not Fnd Is Nothing Then Fnd.Offset(0, -1).Value = txt_Date.Value
End If
With Worksheets("PostHistory")
.Rows(3).EntireRow.Insert Shift:=xlDown
With .Rows(3)
For i = 0 To UBound(Ctls)
.Cells(3 + i).Value = Me.Controls(Ctls(i)).Value
Me.Controls(Ctls(i)).Value = ""
Next i
End With
End With
End Sub
In principle, you don't need to unhide a sheet in order to read from or write to it. Also, if the sheet to which you write is hidden, there is no point in stopping ScreenUpdating. Finally, I did like the way you found to clear all controls but believe that it will interfere with your management of the list in the combo box. Therefore I showed you another method above.
Oh, yes. I created a userform called Augment with one combo box, 3 text boxes and one CommandButton7. I hope that is what you also have.
I am trying to write a simple thing that will merge cells in excel with the same information. What I've got thus far is what follows:
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Set rngMerge = Range("B2:B1000") 'Set the range limits here
Set rngMerge2 = Range("C2:C1000")
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
For Each cell In rngMerge2
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
So the problem I'm encountering is split into two issues, First I'm trying to get this to work for columns A - AK but as you can see above I don't know how to combine it without just making it repeat the same thing 30 times over. Is there another way to group it.
Also when I assign the range to Range("AF2:AF1000") and Range("AG2:AG1000") then excel in its entirety crashes. I was hoping you all could help steer me into the right direction.
Repeat code inside a subroutine is a sign that some of the routines functionality should be extracted into its own method.
Performance
1000 seems like an arbitrary row: Range("B2:B1000"). This range should be trimmed to fit the data.
It is better to Union all the cells to be merged and merge them in a single operation.
Application.DisplayAlerts does not need to be set to True. It will reset after the subroutine has ended.
Public Sub MergeCells()
Dim Column As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each Column In .Columns("A:K")
Set Column = Intersect(.UsedRange, Column)
If Not Column Is Nothing Then MergeEqualValueCellsInColumn Column
Next
End With
Application.ScreenUpdating = True
End Sub
Sub MergeEqualValueCellsInColumn(Target As Range)
Application.DisplayAlerts = False
Dim cell As Range, rMerge As Range
For Each cell In Target
If cell.Value <> "" Then
If rMerge Is Nothing Then
Set rMerge = cell
Else
If rMerge.Cells(1).Value = cell.Value Then
Set rMerge = Union(cell, rMerge)
Else
rMerge.Merge
Set rMerge = cell
End If
End If
End If
Next
If Not rMerge Is Nothing Then rMerge.Merge
End Sub
You keep modifying the cells in rngMerge but not the definition of it before reusing it. This would likely work better if you started at the bottom and worked up as the situation is similar to inserting or deleting rows.
Option Explicit
Private Sub MergeCells()
Dim i As Long, c As Long, col As Variant
Application.DisplayAlerts = False
'Application.ScreenUpdating = false
col = Array("B", "C", "AF", "AG")
For c = LBound(col) To UBound(col)
For i = Cells(Rows.Count, col(c)).End(xlUp).Row - 1 To 2 Step -1
If Cells(i, col(c)).Value = Cells(i, col(c)).Offset(1, 0).Value And Not IsEmpty(Cells(i, col(c))) Then
Cells(i, col(c)).Resize(2, 1).Merge
Cells(i, col(c)).HorizontalAlignment = xlCenter
Cells(i, col(c)).VerticalAlignment = xlCenter
End If
Next i
Next c
Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I've added a wrapping loop that cycles through multiple columns pulled from an array.
I've also notice the Private nature of the sub procedure and I'm guess that this is in a worksheet's private code sheet (right-click name tab, View Code). If the code is to be run on multiple worksheets, it belongs in a public module code sheet (in the VBE use Insert, Module) and proper parent worksheet references should be added to the Cells.
It appears you are running the same procedure on rngMerge and rngMerge2, and that they are the same size.
I suggest the following, where you just iterate through the columns, and then through the cells in each column:
Option Explicit
Private Sub MergeCells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rngMerge As Range, cell As Range
Dim rngFull As Range
Set rngFull = Range("B2:AK1000")
For Each rngMerge In rngFull.Columns
For Each cell In rngMerge.Cells
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
Range(cell, cell.Offset(1, 0)).Merge
'Add formatting statements as desired
End If
Next cell
Next rngMerge
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub
NOTE As written, this will only handle duplicates. If you have triplets or more, only pairs of two will be combined.
I would frame the problem a bit differently. Your code goes through each cell in the range, compares it to the next cell, and, if the values of the two are equivalent, then merge them together. I think it a bit clearer to check each cell against the previous cell value instead.
Also, you can iterate over the columns in order to avoid code repetition (as mentioned in other answers).
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
'Because the Sheets property can return something other than a single worksheet, we're storing the result in a variable typed as Worksheet
Set wks = Sheets("Sheet1")
'To run this code across the entire "used part" of the worksheet, use this:
Set mergeRange = wks.UsedRange
'If you want to specify a range, you can do this:
'Set mergeRange = wks.Range("A2:AK1000")
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
'cell.Offset(-1) will return the previous cell, even if that cell is part of a set of merged cells
'In that case, the following will return the first cell in the merge area
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
If you want to run this code on multiple ranges, you can isolate the code which carries out the merges within a range, into its own Sub procedure:
Sub MergeCellsInRange(mergeRange As Range)
For Each column In mergeRange.Columns
For Each cell In column.Cells
If cell.Row > 1 Then
Set previousCell = cell.Offset(-1).MergeArea(1)
If cell.Value = previousCell.Value And Not IsEmpty(cell) Then
cell.Value = ""
wks.Range(previousCell, cell).Merge
End If
End If
Next
Next
End Sub
and call it multiple times from your main procedure:
Sub MergeCells()
Dim wks As Worksheet
Dim mergeRange As Range
Dim column As Range
Dim cell As Range
Dim previousCell As Range
Set wks = Sheets("Sheet1")
MergeRange wks.Range("A2:U1000")
MergeRange wks.Range("AA2:AK1000")
End Sub
References:
Excel object model
Global Sheets property, Sheets collection
Worksheet object
UsedRange property
Range object
Cells property
Row property
Offset property
MergeArea property
Value property
VBA
For Each ... In construct
IsEmpty function
Dim statement
Set statement
Sub statement
I have a macro and its dependent on Specific sheet name 'PRODUCTS45' problem is if a user run the macro on different sheet e.g. Sheet1 it throws debug error.
can anyone help me to make macro run only when sheet 'PRODUCTS45' is present and if not throws msgbox that mandatory sheet is not present.
Option Explicit
Sub FlagWord()
Dim R As Range, WS As Worksheet
Dim RE As Object
Dim C As Range, D As Range
Dim S As String
Dim I As Long, J As Long
S = InputBox("Enter desired word")
'Current filled in range
Set WS = Worksheets("SHEET")
'case sensitive sheet name and its required to run macro if this is not present macro should not run
With WS
Set R = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set R = R.Resize(columnsize:=.Cells(1, .Columns.Count).End(xlToLeft).Column)
End With
If Not S = "" Then
'If S not present then add column
With WS.Rows(1)
Set C = .Find(what:=S, after:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext, MatchCase:=False)
End With
'Add column if not already present
If C Is Nothing Then
Set R = R.Resize(columnsize:=R.Columns.Count + 1)
R(1, R.Columns.Count) = S
End If
End If 'no new column if S is blank
'do the word match
'Clear the data area
With R
.Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).ClearContents
End With
'fill in the data
'use regex to allow for easy word boundaries
Set RE = CreateObject("vbscript.regexp")
With RE
.Global = False 'only need a single match
.ignorecase = True
For Each C In R.Columns(1).Offset(1, 0).Resize(R.Rows.Count - 1).Cells
For Each D In R.Rows(1).Offset(0, 1).Resize(columnsize:=R.Columns.Count - 1).Cells
.Pattern = "\b" & D.Text & "\b"
If .test(C.Text) = True Then
R(C.Row, D.Column) = "YES"
End If
Next D
Next C
End With
End Sub
How about something like this:
Public Sub CheckForSheetBeforeCallingFlagWord()
Dim ws As Worksheet
Dim bolFound As Boolean
bolFound = False
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "PRODUCTS45" Then bolFound = True
Next ws
If bolFound = False Then
MsgBox "Required sheet 'PRODUCTS45' not found." & Chr(10) & "Aborting..."
Exit Sub
End If
Call flagword
End Sub
This procedure checks for the existence of the required sheet. If it is not found then you get a message box and nothing else happens. If the sheet is found then the other procedure gets called (and executed).
Trying to reference a worksheet that doesn't exist will throw an error. You can use an error handler to trap this and give the desired message.
Sub myMacro()
On Error GoTo sheetNotFound
doStuff ThisWorkbook.Sheets("PRODUCTS45")
Exit Sub
sheetNotFound:
MsgBox "PRODUCTS45 not found"
End Sub
Sub doStuff(ws As Worksheet)
' remaining code goes here
End Sub
I'm trying to hide all rows in a worksheet if a reference cell has no text in it. I'm using the following formula
Option Explicit
Private Sub Worksheet_Activate()
Dim r As Range, c As Range
Set r = Range("d4:f1000")
Application.ScreenUpdating = False
For Each c In r
If Len(c.Text) = 0 Then
c.EntireRow.Hidden = True
Else
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
When I run it it runs indefinitely, and I have to exit the program in Task Manager. I think this is happening because I haven't initially defined c. Am I correct about this?
Thank you for taking the time to respond!
first off you can shortened and speed up your code like follows:
Option Explicit
Private Sub Worksheet_Activate1()
Dim r As Range, c As Range
Set r = Range("d4:f1000")
Application.ScreenUpdating = False
For Each c In r
c.EntireRow.Hidden = Len(c.Text) = 0
Next c
Application.ScreenUpdating = True
End Sub
but if you're after hiding all rows where range D4:F100 cells in the same row are blank, then you can use this code:
Private Sub Worksheet_Activate4()
Application.ScreenUpdating = False
With Range("D4:F1000") '<-- reference your range
With .Columns(1).SpecialCells(xlCellTypeBlanks) '<--| reference its 1st column blank cells
With .Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference referenced blank cells whose side cell is blank
With .Offset(, 1).SpecialCells(xlCellTypeBlanks) '<--| reference referenced blank cells whose side cell is blank
.EntireRow.Hidden = True '<--| hide rows when all three cells are blank
End With
End With
End With
End With
Application.ScreenUpdating = True
End Sub
which can be made much less verbose like follows:
Private Sub Worksheet_Activate5()
Application.ScreenUpdating = False
Range("D4:F1000") _
.Columns(1).SpecialCells(xlCellTypeBlanks) _
.Offset(, 1).SpecialCells(xlCellTypeBlanks) _
.Offset(, 1).SpecialCells(xlCellTypeBlanks) _
.EntireRow.Hidden = True '<--| hide rows when all three cells are blank
Application.ScreenUpdating = True
End Sub
with the only caveat that should no rows match that criteria it'd return an error
should this be an issue then just add On Error Resume Next at the top of the sub
I have a problem with excel macro. I am using Excel 2003. I have lots of data in my excel document and i need to make macro so I can see specific data.
All data in this documents is imported from another excel document. I mean it's not value but formula. First row is set for labels of data, like name, surname, number, name of training and so on. Rows below are filled with those data.
What I want to do is:
1. Filter data by specific column criteria.
2. Use macro which does:
- searching in all columns in range (let's say range G:BV) for value "1"
- when value "1" is found in any cell in the column it stays untouched
- when value "1" isn't found column should be hidden
I was trying hard to find something about my problem, however no success. So far I came up with this code:
Sub FindHid()
Dim vFind
Dim rSearch As Range
On Error GoTo 0
vFind = 1
Application.ScreenUpdating = True
For i = 7 To 75
With ActiveSheet.Columns("G:G")
Set rSearch = .Find(vFind, LookIn:=xlValues, MatchCase:=False)
If rSearch Is Nothing Then
.EntireColumn.Hidden = True
Else
.EntireColumn.Hidden = False
End If
End With
Set rSearch = Nothing
Next i
End Sub
I wouldn't use the Find method.
Try with something like:
NRows = ActiveSheet.UsedRange.Rows.Count
For R = 2 To NRows
If Rows(R).Hidden Then
My code:
Sub HideNonOnes()
Dim rngToSearch As Range
Dim rng As Range
Dim rngToHide As Range
Set rngToSearch = Range("G2", Range("G2").End(xlDown).End(xlToRight))
For Each rng In rngToSearch.Columns
If Evaluate("ISNA(MATCH(1," & rng.Address & ",0))") Then
If rngToHide Is Nothing Then
Set rngToHide = rng.Range("A1")
Else
Set rngToHide = Union(rngToHide, rng.Range("A1"))
End If
End If
Next rng
If Not rngToHide Is Nothing Then
rngToHide.Columns.Hidden = True
End If
End Sub
It builds the range rngToHide before hiding all these columns in one go.
It is not the best solution to my problem, however it works:
Sub FindHid()
Dim vFind
Dim rSearch As Range
'On Error GoTo ErrorHandle
Application.ScreenUpdating = False
vFind = 1
Range("F1").Select
For i = 1 To 68
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Set rSearch = Selection.Find(vFind, LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=True)
If rSearch Is Nothing Then
Selection.EntireColumn.Hidden = True
Else
Selection.EntireColumn.Hidden = False
End If
Next i
Application.ScreenUpdating = True
Range("A1").Select
End Sub