Select a column by letter from activeCell (without activeCell.EntireColumn) - vba

First and foremost, the below works as expected. I'm trying to make the macro mimic one we have in word. Our word macro will select the entire column simply to display which column is currently being processed (the selection object is not used for any actual processing).
In excel, when I attempt to select the column (activecell.entirecolumn.select) if there is a merged cell it will show multiple columns. I need it only to select the letter column (pretty much the same as clicking the letter at the top) of the active cell. I'm hoping for a method that wont require me to parse the address of the cell if possible (I feel like string parsing is sloppy).
Sub setwidths()
Dim rangeName As String
Dim selectedRange As range
Dim tempRange As range
Dim x As Integer
'If only 1 cell is selected, attempt to find the correct named range
If Selection.Cells.Count = 1 Then
rangeName = Lib.getNamedRange(Selection) 'Built in function from my lib (works I promise)
If rangeName <> "" Then
Application.Goto reference:=rangeName
End If
End If
Set selectedRange = Selection
'Go column by column asking for the width
'Made to mimic a word MACRO's behavior and moving backwards served a point in word
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x)
tempRange.Cells(tempRange.Cells.Count, 1).Select
'This is where the code should go to select the column
tempRange.ColumnWidth = InputBox("This columns?")
Next
End Sub
Is there anyway to select a column by letter (range("A:A").select for instance) from within an active cell?
Edit:
Record MACRO shows that columns("A:A").select is used when clicking the letter at the top; however, entering that same line into the immediate window will select all columns that merged cells are merged across same as with range("A:A").select and activecell.selectcolumn
Sub NSTableAdjust()
Dim rangeName As String
Dim selectedRange As range
Dim tempRange As range
Dim cellsColor() As Long
Dim cellsPattern() As XlPattern
Dim cellsTaS() As Long
Dim cellsPTaS() As Long
Dim result As String
Dim abort As Boolean
Dim x As Integer
Dim y As Integer
'Delete the block between these comments and run macro on 10x10 grid in excel to test
If Selection.Cells.Count = 1 Then
rangeName = Lib.getNamedRange(Selection)
If rangeName <> "" Then
Application.Goto reference:=rangeName
End If
End If
'Delete the block between these comments and run macro on 10x10 grid in excel to test
Set selectedRange = Selection
ReDim cellsArr(1 To selectedRange.Rows.Count)
ReDim cellsColor(1 To UBound(cellsArr))
ReDim cellsPattern(1 To UBound(cellsArr))
ReDim cellsTaS(1 To UBound(cellsArr))
ReDim cellsPTaS(1 To UBound(cellsArr))
abort = False
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x)
tempRange.Cells(tempRange.Cells.Count, 1).Select
For y = 1 To UBound(cellsColor)
With tempRange.Cells(y, 1).Interior
cellsColor(y) = .Color
cellsPattern(y) = .Pattern
cellsTaS(y) = .TintAndShade
cellsPTaS(y) = .PatternTintAndShade
.Color = 14136213
End With
Next
result = InputBox("This Column?")
If IsNumeric(result) Then
tempRange.ColumnWidth = result
Else
abort = True
End If
For y = 1 To UBound(cellsColor)
With tempRange.Cells(y, 1).Interior
.Color = cellsColor(y)
.Pattern = cellsPattern(y)
.TintAndShade = cellsTaS(y)
.PatternTintAndShade = cellsPTaS(y)
End With
Next
If abort Then
Exit Sub
End If
Next
End Sub
My current solution to simply shade the cells and then restore their original shading after processing the column.

After an obviously lengthy discussion in the comments on the post. It appears the answer to my question is simply "Not Possible."
The solution I settled on in an attempt to get as close to the "Look" I was searching for is below:
For x = selectedRange.Columns.Count To 1 Step -1
Set tempRange = selectedRange.Columns(x) 'Range of the column
'Our standards dictate the last cell in the range will not be merged
With tempRange.Cells(tempRange.Cells.Count, 1)
.Select 'Selecting here will for excel to make sure the range is in view
'Very simple/basic conditional formatting rule
Set fCondition = .EntireColumn.FormatConditions. _
Add(Type:=xlExpression, Formula1:="=True")
fCondition.Interior.Color = 15123099
'Make sure it is the highest priority rule
fCondition.Priority = 1
End With
'Get user input
result = InputBox("This Column?")
'Delete rule
fCondition.Delete
'Validate user input
If IsNumeric(result) Then
tempRange.ColumnWidth = result
Else
abort = True
End If
If abort Then
Exit Sub
End If
Next

Related

VBA/Excel Speed up macro adding checkboxes

I need to add checkbox for each row in few documents and I have script for that which working, and that's ok but...
If I have 10k rows then this script it's very slowly. How I can speed up it?CODE:
Sub AddCheckBoxes()
Dim chk As CheckBox
Dim myRange As Range, cel As Range
Dim ws As Worksheet
Set ws = Sheets("") 'adjust sheet to your need
Set myRange = ws.Range("A65:A75") ' adjust range to your needs
For Each cel In myRange
Set chk = ws.CheckBoxes.Add(cel.Left, cel.Top, 30, 6) 'you can adjust left, top, height, width to your needs
With chk
.Caption = "Valid"
.LinkedCell = cel.Range("B65:B75").Address
End With
Next
End Sub
Thanks!
Let's try this and see if it fits. Please paste the following code into a normal code module (by default 'Module1') of a blank workbook you create for this purpose. It is a module which doesn't exist in a new workbook. Don't use any of the existing.
Option Explicit
Enum Nws ' Worksheet rows & columns
' 20 Apr 2017
NwsFirstDataRow = 2 ' adjust as required
' Columns:
NwsMainData = 1 ' (= A) Test for used range
NwsCheck = 7 ' (= G) column for Check cell
End Enum
Enum Nck ' CheckBox
' 20 Apr 2017
NckFalse
NckTrue
NckNotSet ' any value other than True or False
End Enum
Sub SetCheckCell(Target As Range)
' 20 Apr 2017
Dim TgtVal As Nck
With Target
If Len(.Value) Then
Select Case .Value
Case True
TgtVal = NckFalse
Case False
TgtVal = NckTrue
Case Else
TgtVal = NckNotSet
End Select
Else
TgtVal = NckNotSet
End If
If TgtVal = NckNotSet Then
SetBorders Target
TgtVal = NckFalse
End If
.Value = CBool(Array(0, -1)(TgtVal))
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = Array(xlThemeColorAccent6, xlThemeColorAccent3)(TgtVal)
.TintAndShade = 0.399945066682943
.PatternTintAndShade = 0
End With
.Offset(0, -1).Select
End With
End Sub
Private Sub SetBorders(Rng As Range)
' 12 Apr 2017
Dim Brd As Long
For Brd = xlEdgeLeft To xlInsideHorizontal
SetBorder Rng, Brd
Next Brd
Rng.Borders(xlDiagonalDown).LineStyle = xlNone
Rng.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub
Private Sub SetBorder(Rng As Range, _
Brd As Long)
' 12 Apr 2017
With Rng.Borders(Brd)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.349986266670736
.Weight = xlMedium
End With
End Sub
In column A, enter something - anything - in row 10 (or thereabouts). This is the last "used" row in your worksheet.
Now paste the following code in the code sheet of the worksheet on which you created a last "used" row. It must be exactly that code sheet - no other. It is a sheet which already exists. You recognise it by the tab's name in the VBE's project explorer window.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' 20 Apr 2017
Dim Rng As Range ' used range (almost)
Dim Rl As Long ' last row
Application.EnableEvents = False
With Target.Worksheet
Rl = .Cells(.Rows.Count, NwsMainData).End(xlUp).Row
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsCheck), .Cells(Rl, NwsCheck))
If Not Application.Intersect(Target, Rng) Is Nothing Then
SetCheckCell .Cells(Target.Row, NwsCheck)
End If
End With
Application.EnableEvents = True
End Sub
Now you are all set to test but understand the mechanics first. At the top of the first batch of code you have Enum Nws which specifies one row and two columns. The specified row is NwsFirstDataRow with an assigned value of 2. It means that row 1 is outside the scope of this code. The code will not run when you click in row 1 (presumably a caption row). You could set NwsFirstDataRow to a value of 3, thereby creating 2 header rows which the code won't touch.
The two columns are NwsMainData and NwsCheck. NwsMainData is the column where the last row is measured. If you click below the last row the code will not run. You might find that column A doesn't suit your needs. You can set any other value, thereby specifying another column. The number you set is used for no other purpose but to find the last row. In your test, make sure the column actually has a used row.
NwsCheck is the column where you will have your "check box". You can specify any column. Try it out in a little while. The point is that the code will not run if you click any other column. Therefore, the code will run if you click in the NwsCheck column, at or below NwsFirstDataRow and at or above the last "used" row. Go ahead an click.
Since the cell is empty it will be coloured as a checkbox and filled with the word "False". Click it again and it will change colour and value will be True. It continues to toggle. The cursor moves to the left to allow you to toggle.
You could move the cursor right or up or down. You could change the colours to any colour Excel has on offer. You can change the frame from the one I have selected. You can change the words which are shown. In fact, there is very little you couldn't change - and it isn't difficult.
The question is whether the idea can be adapted to do the job you want a check box to do.
Here is a variation of the above. Instead of writing TRUE or FALSE, it actually gives you a checkbox-character which is either checked or not. The code displays a message box informing you of the status, but the idea is to execute whatever code you want to run instead, based on whether the box is checked or not.
To test this code, add this procedure to the normal code module. Some of the above code will be required for this solution. For the purpose of testing, just have the entire previous code installed. Then add this.
Function SetCheck(Cell As Range) As Boolean
' 21 Apr 2017
Dim Fun As Integer
Dim Chars() As Variant
Dim Mark As Integer ' character current displayed
Chars = Array(168, 254) ' unchecked / checked box
With Cell
If Len(.Value) Then Mark = AscW(.Value)
Fun = IIf(Mark = Int(Chars(0)), 1, 0)
With .Font
.Name = "Wingdings"
.Size = 11
End With
.Value = ChrW(Chars(Fun))
.Offset(0, 1).Select
End With
SetCheck = CBool(Fun)
End Function
Replace the existing event procedure with the one below. The difference is minute, but for quick testing, just replace all of it.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' 21 Apr 2017
Dim Rng As Range ' used range (almost)
Dim Rl As Long ' last row
Dim Chk As Boolean
Application.EnableEvents = False
With Target.Worksheet
Rl = .Cells(.Rows.Count, NwsMainData).End(xlUp).Row
Set Rng = .Range(.Cells(NwsFirstDataRow, NwsCheck), .Cells(Rl, NwsCheck))
If Not Application.Intersect(Target, Rng) Is Nothing Then
' SetCheckCell .Cells(Target.Row, NwsCheck)
Chk = SetCheck(Target.Cells(1))
MsgBox "The checkbox is now " & IIf(Chk, "", "un") & "checked"
End If
End With
Application.EnableEvents = True
End Sub

Hiding columns in excel based on the value of a cell

My goal is to hide the column if all value from row 3 to 10 are zero in that column, so I create formula in the row 11 which is sum of the value from row 3 to 10
Basicly I can create code like this
If Range("B11").Value = 0 Then
Columns("B:B").EntireColumn.Hidden = True
Else
Columns("B:B").EntireColumn.Hidden = False
End If
If Range("C11").Value = 0 Then
Columns("C:C").EntireColumn.Hidden = True
Else
Columns("C:C").EntireColumn.Hidden = False
End If
but how to simply this, because I want to this macro run from Column B to FV,
or maybe any other solution to achieve my goal?
A well placed loop would help and the join function:
Dim X as Long
Columns("B:FV").EntireColumn.Hidden = False
For X = 2 To 178
If Join(Application.Transpose(Range(Range(Cells(3, X).Address & ":" & Cells(10, X).Address).Address).Value), "") = "00000000" Then Columns(X).Hidden = True
Next
Unhide ALL the columns first then you have removed the need for your else statement
Edit: With this solution, you also don't need your formula in row 11.
I have surprised no one write the easiest answer.
for i = 2 to 178
if cells(11, i).value = 0 then
Columns(i).EntireColumn.Hidden = True
end if
next
Heres one way.
Sub test()
Dim iStart As Long: iStart = Range("B1").Column
Dim iFin As Long: iFin = (Range("FV1").Column) - 1
Dim iCntCol As Long: iCntCol = iStart 'Col B is #2
For iCntCol = iStart To iFin 'FV is Col # 178
If Cells(11, iCntCol).Value = 0 Then
Columns(iCntCol).EntireColumn.Hidden = True
Else
Columns(iCntCol).EntireColumn.Hidden = False
End If
Next iCntCol
End Sub
HTH
should performance be an issue, consider what follows
Option Explicit
Sub hide()
Dim found As Range
With Intersect(ActiveSheet.Range("B11:FV11"), ActiveSheet.UsedRange.EntireColumn)
.EntireColumn.Hidden = False
.FormulaR1C1 = "=sum(R3C:R10C)"
Set found = GetZeroColumns(.Cells, 0)
End With
If Not found Is Nothing Then found.EntireColumn.Hidden = True
End Sub
Function GetZeroColumns(rng As Range, value As Variant) As Range
Dim firstAddress As String
Dim found As Range
With rng
Set found = .Find(What:=value, LookIn:=xlValues, lookat:=xlWhole)
If Not found Is Nothing Then
firstAddress = found.Address
Set GetZeroColumns = found
Do
Set GetZeroColumns = Union(GetZeroColumns, found)
Set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> firstAddress
End If
End With
End Function
We could use a more versatile code to do this, by not hard coding the range of consideration, so that it can be reused in many places. Consider below, the For...Next loop will test each cell in Selection. Selection is the current selected cells. So just select the cells you want the code to run on. If a cell's value equals 0, then the column will be marked for hiding. I'd also not recommend hiding the column one-by-one, it makes the code unnecessarily slow, especially when there are a lot of formulas in the sheet or there are many columns to hide. So what i did is just mark the columns for hiding using the Union function. Then hide them at one go which you can see at the last line of the code.
Sub HideZerosByColumn()
Dim iRng As Range
Dim uRng As Range
Set uRng = Nothing
For Each iRng In Selection
If iRng = 0 And Not IsEmpty(iRng) Then
If uRng Is Nothing Then Set uRng = iRng Else Set uRng = Union(uRng, iRng)
End If
Next iRng
If Not uRng Is Nothing Then uRng.EntireColumn.Hidden = True
End Sub
Before running the code, select the range for consideration.
After running the code

Finding all cells that have been filled with any color and highlighting corresponding column headers in excel vba

My problem:
I've made a large (2,000 line) macro that runs on our company's template and fixes some common issues and highlights other issues we have prior to importing. The template file always has 150 columns and is in most instances 15,000+ rows (sometimes even over 30,000). The macro works well, highlighting all the cells that contain errors according to our data rules, but with a file with so many columns and rows I thought it'd be convenient to add a snippet to my macro that would have it find all of the cells that have been highlighted and then highlight the column headers of the columns that contain those highlighted cells.
Methods I've found while searching for a solution:
SpecialCellsxlCellTypeAllFormatConditions only works for conditional formatting, so that isn't a plausible method for my situation
Rick Rothstein's UDF from here
Sub FindYellowCells()
Dim YellowCell As Range, FirstAddress As String
Const IndicatorColumn As String = "AK"
Columns(IndicatorColumn).ClearContents
' The next code line sets the search for Yellow color... the next line after it (commented out) searches
' for the ColorIndex 6 (which is usually yellow), so use whichever code line is applicable to your situation
Application.FindFormat.Interior.Color = vbYellow
'Application.FindFormat.Interior.ColorIndex = 6
Set YellowCell = Cells.Find("*", After:=Cells(Rows.Count, Columns.Count), SearchFormat:=True)
If Not YellowCell Is Nothing Then
FirstAddress = YellowCell.Address
Do
Cells(YellowCell.Row, IndicatorColumn).Value = "X"
Set YellowCell = Cells.Find("*", After:=YellowCell, SearchFormat:=True)
If YellowCell Is Nothing Then Exit Do
Loop While FirstAddress <> YellowCell.Address
End If
End Sub
This would be perfect with a few tweaks, except our files can have multiple colorfills. Since our template is so large I've learned that it takes quite some time to run one instance of Find to find just one colorfill in the UsedRange.
Using filtering, maybe cycling through all the columns and checking each if they contain any cell that has any colorfill. Would that be any faster though?
So, my question:
How could I accomplish finding all columns that contain any colorfilled cells? More specifically, what would be the most efficient (fastest) way to achieve this?
The most performant solution would be to search using recursion by half-interval.
It takes less than 5 seconds to tag the columns from a worksheet with 150 columns and 30000 rows.
The code to search for a specific color:
Sub TagColumns()
Dim headers As Range, body As Range, col As Long, found As Boolean
' define the columns for the headers and body
Set headers = ActiveSheet.UsedRange.Rows(1).Columns
Set body = ActiveSheet.UsedRange.Offset(1).Columns
' iterate each column
For col = 1 To headers.Count
' search for the yellow color in the column of the body
found = HasColor(body(col), vbYellow)
' set the header to red if found, green otherwise
headers(col).Interior.color = IIf(found, vbRed, vbGreen)
Next
End Sub
Public Function HasColor(rg As Range, color As Long) As Boolean
If rg.DisplayFormat.Interior.color = color Then
HasColor = True
ElseIf VBA.IsNull(rg.DisplayFormat.Interior.colorIndex) Then
' The color index is null so there is more than one color in the range
Dim midrow&
midrow = rg.Rows.Count \ 2
If HasColor(rg.Resize(midrow), color) Then
HasColor = True
ElseIf HasColor(rg.Resize(rg.Rows.Count - midrow).Offset(midrow), color) Then
HasColor = True
End If
End If
End Function
And to search for any color:
Sub TagColumns()
Dim headers As Range, body As Range, col As Long, found As Boolean
' define the columns for the headers and body
Set headers = ActiveSheet.UsedRange.Rows(1).Columns
Set body = ActiveSheet.UsedRange.Offset(1).Columns
' iterate each column
For col = 1 To headers.Count
' search for any color in the column of the body
found = VBA.IsNull(body(col).DisplayFormat.Interior.ColorIndex)
' set the header to red if found, green otherwise
headers(col).Interior.color = IIf(found, vbRed, vbGreen)
Next
End Sub
Before:
Running this short macro:
Sub FindingColor()
Dim r1 As Range, r2 As Range, r As Range
Dim nFirstColumn As Long, nLastColumn As Long, ic As Long
Set r1 = ActiveSheet.UsedRange
nLastColumn = r1.Columns.Count + r1.Column - 1
nFirstColumn = r1.Column
For ic = nFirstColumn To nLastColumn
Set r2 = Intersect(r1, Columns(ic))
For Each r In r2
If r.Interior.ColorIndex <> xlNone Then
r2(1).Interior.ColorIndex = 27
Exit For
End If
Next r
Next ic
End Sub
produces:
I just don't know about the speed issue. If the colored cells are near the top of the column, the code will run super fast; if the colored cells are missing or near the bottom of the column, not so much.
EDIT#1:
Please note that my code will not find cells colored conditionally.
The Range.Value property actually has three potential optional xlRangeValueDataType parameters. The default is xlRangeValueDefault and that is all (by omission) most anyone ever uses.
The xlRangeValueXMLSpreadsheet option retrieves an XML data block which describes many of the properties that the cell maintains. A cell with no Range.Interior property beyond xlAutomatic will have the following XML element,
<Interior/>
... while a cell with an .Interior.Color property will have the following XML element,
<Interior ss:Color="#FF0000" ss:Pattern="Solid"/>
It's been well established that dumping a worksheet's values into a variant array and processing in-memory is substantially quicker than looping through cells so retrieving the .Value(xlRangeValueXMLSpreadsheet) and performing an InStr function on the single blob of XML data should prove much faster.
Sub filledOrNot()
Dim c As Long, r As Long, vCLRs As String
appTGGL bTGGL:=False
With Worksheets("30Kdata")
With .Cells(1, 1).CurrentRegion
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
For c = 1 To .Columns.Count
vCLRs = .Columns(c).Cells.Value(xlRangeValueXMLSpreadsheet)
If CBool(InStr(1, vCLRs, "<Interior ss:Color=", vbBinaryCompare)) Then _
.Cells(0, c).Interior.Color = 49407
Next c
End With
End With
Debug.Print Len(vCLRs)
End With
appTGGL
End Sub
Public Sub appTGGL(Optional bTGGL As Boolean = True)
With Application
.ScreenUpdating = bTGGL
.EnableEvents = bTGGL
.DisplayAlerts = bTGGL
.AutoRecover.Enabled = bTGGL 'no interruptions with an auto-save
.Calculation = IIf(bTGGL, xlCalculationAutomatic, xlCalculationManual)
.CutCopyMode = False
.StatusBar = vbNullString
End With
Debug.Print Timer
End Sub
I ran this against 30K rows by 26 columns. While each column was examined, I had only seeded every third column with an .Interior.Color property somewhere randomly within the 30K rows. It took about a minute and a half.
Each column of 30K rows produced an XML record that was almost 3Mbs in size; a length of 2,970,862 was typical. Once read into a variable, it was searched for the fingerprint of a set interior fill.
    
Discarding the read into the string type var and performing the InStr directly on the .Value(xlRangeValueXMLSpreadsheet) actually improved the time by about two seconds.
My proposal using AutoFilter method of Range object
it runs quite fast
Option Explicit
Sub FilterByFillColor()
Dim ws As Worksheet
Dim headerRng As Range
Dim iCol As Long, RGBColor As Long
Set ws = ThisWorkbook.Worksheets("HeadersToColor") '<== set it to your actual name of the data worksheet
Set headerRng = ws.Range("headers") '<== I set a named range "headers" in my test sheet addressing the cells that cointains all headers. but you may use explicit address ie: 'ws.Range("B2:EU150")' for a 150 columns header range
RGBColor = RGB(255, 0, 0)
Application.ScreenUpdating = False
headerRng.Interior.Color = vbGreen
With headerRng.CurrentRegion
For iCol = 1 To .Columns.Count
.AutoFilter Field:=iCol, Criteria1:=RGBColor, Operator:=xlFilterNoFill
If .Columns(iCol).SpecialCells(xlCellTypeVisible).Count < .Rows.Count Then headerRng(iCol).Interior.Color = vbRed
.AutoFilter
Next iCol
End With
Application.ScreenUpdating = True
End Sub

ignore alphabets while looping through cells

From my GUI , I enter numbers like this: 9811,7841 which will be sent to my macro. My macro is:
sub highlight(fm as variant)
dim sh as worksheet
Dim i As Integer
dim j as integer
dim k As Long
Dim rn As Range
din number() as integer
If phm <> 0 Then
phm = Split(phm, ",")
ReDim number(LBound(phm) To UBound(phm)) As Integer
Set sh = w.Worksheets("Sheet1")
sh.Select
Cells.Find("Type").Select
ActiveCell.Offset(1, 0).Select
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
For i = 1 To k
For j = LBound(number) To UBound(number)
number(j) = CInt(phm(j))
If ActiveCell.Value = number(j) Or IsEmpty(ActiveCell.Value) Then
Selection.Interior.ColorIndex = xlNone
Else
Selection.Interior.Color = vbGreen
Exit For
End If
Next j
ActiveCell.Offset(1, 0).Select 'moves activecell down one row.
Next i
End If
ActiveWorkbook.Save
End Sub
I would like to modify my code in such that alphabets are ignored if present in any cell.In the below case, cell3 and cell 5 should be highlighted as my "fm" contains 9811,7841 so cell 1,2,4 are valid.Alphabets should be ignored if any while checking the cells.
Sheet1
cell 1: 9811
cell 2: hello 9811
cell 3: 3428
cell 4: hello 7841
cell 5:hello 2545
The simplest way to do this is with a regular expression. Add a reference to Microsoft VBScript Regular Expressions, then just do a pattern replacement:
Private Function StripNonNumerics(inValue As String) As String
Dim regex As New RegExp
With regex
.Pattern = "\D"
.Global = True
StripNonNumerics = .Replace(inValue, vbNullString)
End With
End Function
Note that there'll be less overhead if you incorporate this into your sub or make the regex a global (that way you don't have to repeatedly create the RegExp object.
I think you are looking for the VBA function "Instr"
https://msdn.microsoft.com/en-us/en-en/library/8460tsh1%28v=vs.90%29.aspx
Assuming that phm is your array that contains one number of fm in every cell:
you need to change your line
If ActiveCell.Value = number(j) Or IsEmpty(ActiveCell.Value) Then
to
If Instr(ActiveCell.Value,number(j)) > 0 Or IsEmpty(ActiveCell.Value) Then

Search for multiple phrase; copy to single sheet across multiple sheets

I am using Microsoft Excel to keep track of tasks. I use a different "sheet" for each job. The structure is with regards to columns and data. I have been trying to create a VBA script that would accomplish the following:
Search sheets 1 - X for a value of "Open" or "Past Due" in a row
Copy all rows with those values into a single sheet (such as a ledger) starting at row 3 (so I can add the headers of the template)
Add a column A with the sheet name so that I know what job it came from.
Run this to my hearts obsessive compulsive behavior pleasure to update with new items
I have been using the following posts to help guide me:
Search a specific word and copy line to another Sheet <- which was helpful but not quite right...
Copying rows to another worksheet based on a search on a grid of tags <-- also helpful, but limited to the activesheet and not looping correctly with my modifications...
The last two evenings have been fun, but I feel like I may be making this harder than necessary.
I was able to create a VBA script (edited from another post here) to sweep through all the worksheets, but it was designed to copy all data in a set of columns. I tested that and it worked. I then merged the code base I was using to identify "Open" or "Past Due" in column C (that worked for only the activesheet) into the code. I marked up my edits to share here. At this point it is not functioning, and I have walked myself dizzy. Any tips on where I fubar-ed the code would be appreciated. My code base I working from is:
Sub SweepSheetsCopyAll()
Application.ScreenUpdating = False
'following variables for worksheet loop
Dim W As Worksheet, r As Single, i As Single
'added code below for finding the fixed values on the sheet
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim h As Long 'h replaced i variable from other code
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
'insert below row match search copy function
For Each cell In Range("B1:L1").Offset(r - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
' original code Rows(r).Copy Destination:=Sheets(2).Rows(j)
Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
j = j + 1
End If
toCopy = False
'Next
'end above row match search function
'below original code that copied everything from whole worksheet
' If W.Cells(r, 1) > 0 Then
' Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
' ThisWorkbook.Worksheets("Summary").Cells(i, 1)
' i = i + 1
' End If
Next r
End If
Next W
End Sub
The working code base to sweep through all the sheets was:
Sub GetParts()
Application.ScreenUpdating = False
Dim W As Worksheet, r As Single, i As Single
i = 4
For Each W In ThisWorkbook.Worksheets
If W.Name <> "Summary" Then
For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
If W.Cells(r, 1) > 0 Then
Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
ThisWorkbook.Worksheets("Summary").Cells(i, 1)
i = i + 1
End If
Next r
End If
Next W
End Sub
And the copy the matched data from the Activesheet is as follows:
Sub customcopy()
Application.ScreenUpdating = False
Dim lastLine As Long
Dim findWhat As String
Dim findWhat1 As String
Dim findWhat2 As String
Dim toCopy As Boolean
Dim cell As Range
Dim i As Long
Dim j As Long
'replace original findWhat value with new fixed value
findWhat = "Open"
'findWhat2 = "Past Due"
lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here
'below code does nice job finding all findWhat and copying over to spreadsheet2
j = 1
For i = 1 To lastLine
For Each cell In Range("B1:L1").Offset(i - 1, 0)
If InStr(cell.Text, findWhat) <> 0 Then
toCopy = True
End If
Next
If toCopy = True Then
Rows(i).Copy Destination:=Sheets(2).Rows(j)
j = j + 1
End If
toCopy = False
Next
i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
Application.ScreenUpdating = True
End Sub
You should look into this Vba macro to copy row from table if value in table meets condition
In your case, you would need to create a loop, using this advanced filter to copy the data to your target range or array.
If you need further advice, please post your code, and where you are stuck with it.