I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.
Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:
Sub Test()
Dim StringToFind As String
Dim i As Range
Dim cell As Range
StringToFind = " Testing Test"
With Worksheets("Sheet1")
Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
MatchCase:=False, searchformat:=False)
If Not cell Is Nothing Then
For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
If IsNumeric(i.Value) Then
If i.Value > 0 Then
i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
End If
Next i
Else
End If
End With
End Sub
Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.
Sub FindAndCopy()
' 221
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Caps() As String ' captions to find
Dim Fnd As Range ' found caption
Dim Tgt As Range ' Target
Dim Arr As Variant ' Value of Fnd
Dim f As Integer ' loop counter: Caps
With ThisWorkbook
Set WsS = .Worksheets("Sheet1") ' change to suit
Set WsT = .Worksheets("Sheet2") ' change to suit
End With
Caps = Split("Testing Test,CASH", ",") ' extend to suit
For f = 0 To UBound(Caps)
Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Fnd Is Nothing Then Exit For
Set Fnd = Fnd.Offset(1)
If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
Arr = Fnd.Value ' copies Values, not Formulas
With WsT
Set Tgt = .Cells(1, 1)
If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If VarType(Arr) >= vbArray Then
Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Else
Tgt.Value = Arr
End If
End With
Next f
End Sub
Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps.
Related
I'm creating a macro that is formatting a collection of files and a step in this process is to delete columns that aren't required, keeping a specific set of columns.
I know I can delete columns based on their location and I have this approach implemented already ie 1,3,7 etc or A, C, G etc. But I'm conscious that the report being used might change layout or add extra columns over time and I want to ensure the required columns are kept.
Ideally this code would cycle through each column header starting at A1 until the last column and delete an entire column if the header value isn't found in a list. This list will be an array captured from a range in one of the sheets in the workbook.
List = {Blue, Green, Orange}
Original Table
Blue
Red
Green
Orange
Black
row
row
row
row
row
Formatted Table
Blue
Green
Orange
row
row
row
Does anyone have any suggestions on the approach I could take to get this working or if it's even possible? Any help would be greatly appreciated
You might profit from the following approach by reordering a datafield array via Application.Index which allows even to move the existing columns to any new position.
Note: this flexible solution can be time consuming for greater data sets,
where I would prefer other ways you can find in a lot of answers at SO.
Sub ReorderColumns()
Const headerList As String = "Blue,green,Orange"
'a) define source range
Dim src As Range
Set src = Tabelle3.Range("A1:E100")
'b) define headers
Dim allHeaders: allHeaders = src.Resize(1).Value2
Dim newHeaders: newHeaders = Split(headerList, ",")
'c) get column positions in old headers
Dim cols
cols = getCols(newHeaders, allHeaders)
'd) define data
Dim data As Variant
data = src.Value2
'e) reorder data based on found column positions
data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), cols)
'f) overwrite source data
src = vbNullString ' clear
src.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help function getCols()
Function getCols(individualHeaders, allHeaders)
'Purp: get 1-based column numbers of found headers via Match
getCols = Application.Match(individualHeaders, allHeaders, 0) ' 1-based
End Function
Please, test the next code. It is compact and fast enough. It will build the columns to be deleted range using Application.Match for the two involved arrays (the existing headers one and the ones to be kept). This code assumes that the headers exist in the first row of the processed sheets, starting from A:A column (If starting from a different column, the code can be adapted:
Sub DeleteColunsNotInArrayDel()
Dim sh As Worksheet, arrStay, lastCol As Long, arrH, arrCols, rngDel As Range
Set sh = ActiveSheet 'use here the sheet you need to process
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
arrH = Application.Transpose(Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2)) 'existing headers array
arrCols = Application.IfError(Application.match(arrH, arrStay, 0), "xx") 'match the two arrays and place "xx" where no match has been found
makeColsRng(arrCols).Delete 'delete the columns range, at once
End Sub
Function makeColsRng(arr) As Range
Dim i As Long, colL As String, strAddr As String
For i = LBound(arr) To UBound(arr) 'iterate between the matched arrays array
If arr(i) = "xx" Then 'for the not matching case:
colL = Split(cells(1, i).Address, "$")(1) 'extract the letter of the respective column
strAddr = strAddr & colL & "1," 'build the string of the columns to be deleted range
End If
Next i
Set makeColsRng = Range(left(strAddr, Len(strAddr) - 1)).EntireColumn 'return the necessary range
End Function
In case of headers not starting from the first sheet column, the function can easily be adapted by adding a new parameter (the first column number) to be added when the range to be deleted is built.
The above suggested solution is a fancy one, just for the sake of showing the respective approach, which is not too often used. It may have a limitation of the range building, in case of a string bigger than 254 digits, No error handling for the case of everything matching (even, easy to be added). The next version is standard VBA, compact, more reliable, faster and easier to be understood:
Sub DeleteColunsRangeNotInArray()
Dim sh As Worksheet, arrStay, lastCol As Long, rngH As Range, rngDel As Range, i As Long
Set sh = ActiveSheet
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
Set rngH = sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)) 'existing headers range
For i = 1 To rngH.Columns.count
If IsError(Application.match(rngH(i).Value, arrStay, 0)) Then 'if not a match in arrStay:
addToRange rngDel, rngH(i) 'build a Union range
End If
Next i
'delete the not necessary columns at once:
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Dynamic Named Range
I think a dynamic named range is an excellent choice for storing and retrieving your required columns. Please see the link I provided from https://exceljet.net/ to setup your dynamic named range.
Generic formula =$A$2:INDEX($A:$A,COUNTA($A:$A))
Regular Expression Approach
After reading in your named range, one approach for testing your columns is using regular expressions. To use this you will need to set a library reference to Microsoft VBScript Regular Expressions 5.5. The pipe character | represents an or statement, so we can join our array using that delimiter.
Deleting Ranges in loops
When deleting columns or rows within a loop, the best approach I have found is to union the ranges together in a variable and execute the deletion in one go. This helps performance and it prevents errors from deleting ranges the loop is working on.
I do this so often that I created a custom function for this UnionRange
' Helper function that allows
' concatinating ranges together
Public Function UnionRange( _
ByRef accumulator As Range, _
ByRef nextRange As Range _
)
If accumulator Is Nothing Then
Set UnionRange = nextRange
Else
Set UnionRange = Union(accumulator, nextRange)
End If
End Function
Putting it all together
Below is my implementation of what your code could look like, just make sure to first:
Create a Dynamic Named Range and populate with your required headers
Add Microsoft VBScript Regular Expressions 5.5 reference
Update Sheet1 to whatever sheet your table exists (possibly change logic for finding header row based on your needs)
' Need Regular Expressions Referenced in order to work!
' #libraryReference {Microsoft VBScript Regular Expressions 5.5}
Public Sub DemoDeletingNonRequiredColumns()
' Make sure to create a named range
' otherwise this section will fail. In this
' example the named range is `RequiredColumns`
Dim requiredColumns() As Variant
requiredColumns = Application.WorksheetFunction.Transpose( _
Range("RequiredColumns").Value2 _
)
' To test if the column is in the required
' columns this method uses regular expressions.
With New RegExp
.IgnoreCase = True
' The pipe charactor is `or` in testing.
.Pattern = Join(requiredColumns, "|")
Dim headerRow As Range
' This example uses `Sheet1`, but update to
' the actual sheet you are using.
With Sheet1
Set headerRow = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
End With
Dim column As Range
For Each column In headerRow
' If the column name doesn't match the
' pattern, then concatenate it to the
' toDelete range.
If Not .Test(column.Value2) Then
Dim toDelete As Range
Set toDelete = UnionRange(toDelete, column.EntireColumn)
End If
Next
End With
' toDelete is used as it provides better performance
' and it also prevents errors when deleting columns
' while looping.
If Not toDelete Is Nothing Then
toDelete.Delete
Set toDelete = Nothing
End If
End Sub
Delete Columns Not In a List
Option Explicit
Sub DeleteIrrelevantColumns()
' Source - the worksheet containing the list of headers.
Const sName As String = "Sheet2"
Const sFirstCellAddress As String = "A2"
' Destination - the worksheet to be processed.
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sData() As Variant
With sfCell
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
sData = .Resize(slCell.Row - .Row + 1).Value
End With
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sValue As Variant
Dim sr As Long
For sr = 1 To UBound(sData)
sValue = sData(sr, 1)
If Not IsError(sValue) Then ' exclude error values
If Len(sValue) > 0 Then ' exclude blanks
sDict(sValue) = Empty ' write
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range
With dfCell
Dim dlCell As Range: Set dlCell = _
.Resize(, dws.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set drg = .Resize(, dlCell.Column - .Column + 1)
End With
Dim dData() As Variant: dData = drg.Value
Dim dCells As Range
Dim dValue As Variant
Dim dc As Long
For dc = 1 To UBound(dData, 2)
dValue = dData(1, dc)
If sDict.Exists(dValue) Then
' If duplicate columns, keep only the left-most.
sDict.Remove dValue
Else
' Combine the irrelevant header cells into a range.
If dCells Is Nothing Then
Set dCells = drg.Cells(dc)
Else
Set dCells = Union(dCells, drg.Cells(dc))
End If
End If
Next dc
' Delete columns in one go.
If Not dCells Is Nothing Then
dCells.EntireColumn.Delete
End If
' Inform.
If sDict.Count = 0 Then
MsgBox "Irrelevant columns deleted.", vbInformation
Else
MsgBox "Irrelevant columns deleted." & vbLf & vbLf _
& "Columns not found:" & vbLf _
& Join(sDict.Keys, vbLf), vbCritical
End If
End Sub
I have two worksheets, one generated automatically by another Macro I already have, this one generates data in a new WorkSheet called "SheetN" where N is a numerical value that depends on how many times this macro has been executed.
Then, in my PrincipalSheet I have something like:
Column R
User1; User2; User3;
User2; User4;
User2; User3; User5; User6;
In my auto generated SheetN I have:
Column B
User3;
User2;
NAN
I want to be able to iterate through SheetN column B until is empty and make a find all based on every row that is not NAN and then replace with "" in the PrincipalSheet:
Column R
User1;
User4;
User5; User6;
So far I have an idea to do something like
Sub Test2()
Dim i As Integer
Dim max As Integer
i = 1
i = 20
While i < max
If IsNot IsEmpty(ThisWorkbook.Sheets(NewSheet).Cells(2, i)) Then
MsgBox ThisWorkbook.Sheets(NewSheet).Cells(2, i)
End If
i = i + 1
Wend
End Sub
To retrieve the values from SheetN but this is not working, I'd really appreciate some help.
In the code I admitted that in SheetN columnB you can have duplicate values.
Sub ReplaceUserWithBlank()
Dim ws1 As Worksheet: Set ws1 = Sheets("Principal")
Dim ws2 As Worksheet: Set ws2 = Sheets("SheetN")
Dim lRowColB As Long: lRowColB = ws2.Cells(Rows.Count, "B").End(xlUp).Row
Dim lRowColR As Long: lRowColR = ws1.Cells(Rows.Count, "R").End(xlUp).Row
Dim rngColB As Range: Set rngColB = ws2.Range("B2:B" & lRowColB)
Dim rngColR As Range: Set rngColR = ws1.Range("R2:R" & lRowColR)
Dim rngTemp As Range: Set rngTemp = ws2.Range("K2:K" & lRowColB)
' copy column B to temporary column 'K'
rngColB.Copy rngTemp
' set range in column 'K'
Set rngTemp = Range(rngTemp, rngTemp.End(xlDown))
' Remove dulipcates
rngTemp.RemoveDuplicates Columns:=1, Header:=xlNo
' reset rngTemp
Set rngTemp = ws2.Range("K2", ws2.[K2].End(xlDown))
' Replace with blank
Dim rCell As Range
For Each rCell In rngTemp
rngColR.Replace What:=rCell.Value, Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
Next rCell
' Trim and Clean
For Each rCell In rngColR
rCell.Value = Application.WorksheetFunction.Clean(Trim(rCell.Value))
Next rCell
' Clear temporary range 'K'
rngTemp.Clear
End Sub
I'm currently reorganizing some columns using VBA code and I need to make a change to one of the header rows and the values in 1 specific column. I've included what I'm basically trying to do in a comment. Here is the code I'm using but very cut down for brevity.
Sub columnOrder2()
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer
colOrdr = Array("User name", "LanID", "Asset Tag")
cnt = 1
For indx = LBound(colOrdr) To UBound(colOrdr)
Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
' If search = "LanID" then change header row to "Last3"
' and return only the last 3 characters for values in cells
If Not search Is Nothing Then
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx
End Sub
Currently, I'm just running the code and manually renaming the column then creating a formula in cell g2 and using =Right(G2,3) and copying it down to the rest of the cells in column C. I know VBA can do this much better and maybe even just in a separate function. Any help would be appreciated. I haven't worked with Excel VBA for awhile now.
Assuming you mean to overwrite the LANId column with its own last three characters, you could code as follows (C2 instead of G2 in your question?):
Modified code close to OP
Includes a fully qualified (worksheet) range reference, btw (as otherwise VBA assumes any currently active worksheet) :-)
Sub columnOrder2()
Dim ws As Worksheet: Set ws = Sheet1 ' << Using e.g. the sheet's Code(Name)
Dim colOrdr As Variant
colOrdr = Array("User name", "LanID", "Asset Tag")
Dim cnt As Long
cnt = 1
Dim indx As Long
For indx = LBound(colOrdr) To UBound(colOrdr)
Dim search As Range
Set search = ws.Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not search Is Nothing Then
If LCase(search.Text) = "lanid" Then
'set column range object to memory
Dim rng As Range
Set rng = getColRange(ws, search.Column, Startrow:=1)
'return only the last 3 characters
rng.Value = Evaluate("=Right(" & rng.Address & ",3)")
'change header cell from "LANId" to "Last3"
rng(1, 1) = "Last3" ' change header from LANId to Last3
End If
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx
End Sub
Help function
Returns the range of a given sheet column up to the last row with a value:
Function getColRange(mySheet As Worksheet, _
Optional ByVal myColumn As Variant = "A", _
Optional ByVal Startrow As Long = 1) As Range
With mySheet
'a) change numeric column number to letter(s)
If IsNumeric(myColumn) Then myColumn = Split((.Columns(myColumn).Address(, 0)), ":")(0)
'b) get last row in given column
Dim lastRow As Long
lastRow = .Range(myColumn & .Rows.Count).End(xlUp).Row
'c) return data range as function result
' (a Range is an Object and has to be SET!)
Set getColRange = .Range(myColumn & Startrow & ":" & myColumn & lastRow)
End With
End Function
Related link
Instead of moving entire columns one after the other you might be interested in an array approach - c.f. Delete an array column and change position of two columns
I have two spreadsheets, vda.xlsx and main.xlsm. At the moment I'm comparing the values in:
main.xlsm column J
with
vda.xlsx column A
To see if there is a match. If a match is found then the value in column gets highlighted in red.
However the format of the data in vda.xlsx column A has changed .
It used to look like this
1234
Now it looks like this
Test\1234 or Best\1234 or Jest\1234 - it could be anything...
Sp I need to split Test\1234 by the "\" and extract 1234 for comparison.
Any idea how I can accomplish this. This is my code so far:
Sub VDA_Update()
Dim wshT As Worksheet
Dim wbk As Workbook
Dim wshS As Worksheet
Dim r As Long
Dim m As Long
Dim cel As Range
Application.ScreenUpdating = False
Set wshT = ThisWorkbook.Worksheets("Master")
On Error Resume Next
' Check whether vda.xlsx is already open
Set wbk = Workbooks("vda.xlsx")
On Error GoTo 0
If wbk Is Nothing Then
' If not, open it
Set wbk = Workbooks.Open("C:\Working\vda_test.xlsx")
End If
' Set worksheet on vda.xlsx
Set wshS = wbk.Worksheets("imac01")
m = wshT.Cells(wshT.Rows.Count, 1).End(xlUp).Row
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
Application.ScreenUpdating = True
End Sub
Use Split(CellValue, "\") to get an array and then retrieve the last item in the array.
Change:
' Loop though cells in column J on main.xlsm
For r = 1 To m
' Can we find the value in column C of vda.xlsx?
Set cel = wshS.Columns(1).Find(What:=wshT.Cells(r, 10).Value, _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
wshT.Cells(r, 10).Font.ColorIndex = 3
End If
Next r
To something like:
' Loop though cells in column A on vda.xlsx
For r = 1 To m
' Can we find the value in column J of main.xlsm?
cellSplit = Split(wshS.Cells(r, 1).Value, "\")
Set cel = wshT.Columns(10).Find(cellSplit(UBound(cellSplit)), _
LookAt:=xlWhole, MatchCase:=False)
If Not cel Is Nothing Then
' If we find a match, then change the text to red
cel.Cells(1, 1).Font.ColorIndex = 3
End If
Next r
I am trying to create a macro in excel 2010 that finds every cell in a sheet with a value of "All Customers." Every time that value is found I need a blank row inserted below it. Thought it would be pretty simple but I have searched I many forums and tried to use some sample code and I can't get it to work properly. I am a complete newb when it comes to VBA stuff. Thought I would post here and go do some light reading on basics of VBA.
If anyone has any good training resources, please post those as well.
Thanks in advance!
EDIT: In my OP, I neglected to mention that any row that contains a value of "All Customers" would ideally be highlighted and put in bold, increased size font.
These actions are something that an old Crystal Report viewing/formatting program used to handle automatically when pulling the report. After we upgraded the program I learned that this type of formatting ability had been removed with the release of the newer version of the program, according to the software manufacturer's tech support. Had this been defined in the release notes I would have not performed the upgrade. Regardless, that is how I found myself in this macro disaster.
Something like this code adpated from an article of mine here is efficient and avoids looping
It bolds and increase the font size where the text is found (in the entire row, as Tim points out you should specify whether you meant by cell only)
It adds a blank row below the matches
code
Option Explicit
Const strText As String = "All Customers"
Sub ColSearch_DelRows()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim strFirstAddress As String
Dim lAppCalc As Long
Dim bParseString As Boolean
'Get working range from user
On Error Resume Next
Set rng1 = Application.InputBox("Please select range to search for " & strText, "User range selection", ActiveSheet.UsedRange.Address(0, 0), , , , , 8)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'Further processing of matches
bParseString = True
With Application
lAppCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'a) match string to entire cell, case insensitive
'Set cel1 = rng1.Find(strText, , xlValues, xlWhole, xlByRows, , False)
'b) match string to entire cell, case sensitive
'Set cel1 = rng1.Find(strText, , xlValues, xlWhole, xlByRows, , True)
'c)match string to part of cell, case insensititive
Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , False)
'd)match string to part of cell, case sensititive
' Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , True)
'A range variable - rng2 - is used to store the range of cells that contain the string being searched for
If Not cel1 Is Nothing Then
Set rng2 = cel1
strFirstAddress = cel1.Address
Do
Set cel1 = rng1.FindNext(cel1)
Set rng2 = Union(rng2.EntireRow, cel1)
Loop While strFirstAddress <> cel1.Address
End If
'Further processing of found range if required
If bParseString Then
If Not rng2 Is Nothing Then
With rng2
.Font.Bold = True
.Font.Size = 20
.Offset(1, 0).EntireRow.Insert
End With
End If
End If
With Application
.ScreenUpdating = True
.Calculation = lAppCalc
End With
End Sub
Public Sub InsertRowAfterCellFound()
Dim foundRange As Range
Set foundRange = Cells.Find(What:="yourStringOrVariant", After:=ActiveCell) 'Find the range with the occurance of the required variant
Rows(foundRange.Row + 1 & ":" & foundRange.Row + 1).Insert 'Insert a new row below the row of the foundRange row
foundRange.Activate 'Set the found range to be the ActiveCell, this is a quick and easy way of ensuring you aren't repeating find from the top
End Sub
You may need to add error handling to the code as you will get an error if no cell with the specified value is found.
Assuming this is on the first sheet ("sheet 1"), here is a slow answer:
Sub InsertRowsBelowAllCustomers()
'Set your worksheet to a variable
Dim sheetOne as Worksheet
Set sheetOne = Worksheets("Sheet1")
'Find the total number of used rows and columns in the sheet (where "All Customers" could be)
Dim totalRows, totalCols as Integer
totalRows = sheetOne.UsedRange.Rows.Count
totalCols = sheetOne.UsedRange.Columns.Count
'Loop through all used rows/columns and find your desired "All Customers"
Dim row, col as Integer
For row = 1 to totalRows
For col = 1 to totalCols
If sheetOne.Cells(row,col).Value = "All Customers" Then
Range(sheetOne.Cells(row,col)).Select
ActiveCell.Offset(1).EntireRow.Insert
totalRows = totalRows + 1 'increment totalRows because you added a new row
Exit For
End If
Next col
Next row
End Sub
This function starts from the last row and goes back up to the first row, inserting an empty row after each cell containing "All Customers" on column A:
Sub InsertRowsBelowAllCustomers()
Dim R As Integer
For R = UsedRange.Rows.Count To 1 Step -1
If Cells(R, 1) = "All Customers" Then Rows(R + 1).Insert
Next R
End Sub
The error is because the worksheet was not specified in used range.
I have slightly altered the code with my text being in column AJ and inserting a row above the cell.
Dim R As Integer
For R = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Range("AJ" & R) = "Combo" Then Rows(R).Insert
Next R