I have the following Macro and want to reduce the number of lines to speed up the process.
5
ActiveCell.Columns("A:A").EntireColumn.Select
If Selection.Find(What:="*", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True) Is Nothing Then
GoTo 6
End If
Selection.Find(What:="*", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=True).Activate
ActiveCell.Select
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
Selection.Insert Shift:=xlToRight
GoTo 5
I want to replace multiple the 'Selection.Insert Shift:=xlToRight' lines with a single line using Offset.
Can you please help!
Replace your x5 Selection.Insert Shift:=xlToRight by Range(ActiveCell, ActiveCell.Offset(0, 4)).Insert shift:=xlToRight
EDIT
More related to your code: Range(Selection, Selection.Offset(0, 4)).Insert shift:=xlToRight
Related
I am having an issue with type mismatch, in my table the value is general since it is copied and pasted values from a pivot table
Error thrown here:
Set mf = Columns("F").Find(What:=ONE, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
Dim ONE As String
Worksheets("Chart").Activate
Columns("A:B").Select
Selection.Copy
Range("F1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
ONE = Cells(2, "F").Value
Sheets("Paste Data Table").Select
Set mf = Columns("F").Find(What:=ONE, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False)
ActiveCell.EntireRow.Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Top 5 Breakdown").Select
Sheets("Top 5 Breakdown").Select
Range("A2").Select
ActiveSheet.Paste
Worksheets("Paste Data Table").Activate
Range("A2").Select
Application.CutCopyMode = False
What causes error in this Find method is:
After:=ActiveCell
You can't search after cell which is not in searched range, column F in this case. Your active cell is not in column F.
This question already has an answer here:
Run-time error 91 using Range.find
(1 answer)
Closed 5 years ago.
I've a 91 error on my code, nothing seems to work.
The next code is for identify each line wich contains LOW, MEDIUM, HIGH according to another table, the problem is that my data doesn't contain 'LOW' by the time, I guess I need to add an IF so the code can start searching MEDIUM value, but I don't know how to do it.
Private Sub CommandButton1_Click()
Dim DataCalc_LOW As Integer
Dim DataCalc_MEDIUM As Integer
Dim DataCalc_HIGH As Integer
DataToCalc_LOW = Worksheets("Random Generator").Range("AL16").Value
DataToCalc_MEDIUM = Worksheets("Random Generator").Range("AL17").Value
DataToCalc_HIGH = Worksheets("Random Generator").Range("AL18").Value
Dim x As Integer
Dim y As Integer
Range("I14").Select
Range(Selection, Selection.End(xlDown)).Select
'x = 0
Do
x = x + 1
Selection.Find(What:="LOW", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False,
SearchFormat:=False).Activate
With ActiveCell
.Interior.ColorIndex = 44
End With
ActiveCell.Select
Selection.Offset(0, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Loop Until x = DataToCalc_LOW
Range("I14").Select
Range(Selection, Selection.End(xlDown)).Select
'y = 0
Do
y = y + 1
Selection.Find(What:="MEDIUM", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False,
SearchFormat:=False).Activate
With ActiveCell
.Interior.ColorIndex = 44
End With
ActiveCell.Select
Selection.Offset(0, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Loop Until y = DataToCalc_MEDIUM
Range("I14").Select
Range(Selection, Selection.End(xlDown)).Select
'Z = 0
Do
Z = Z + 1
Selection.Find(What:="HIGH", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False,
SearchFormat:=False).Activate
With ActiveCell
.Interior.ColorIndex = 44
End With
ActiveCell.Select
Selection.Offset(0, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Loop Until Z = DataToCalc_HIGH
For i = 15 To 5000
cuenta = WorksheetFunction.CountIf(Range("F15:F500"), Cells(i, "F"))
If cuenta = 1 Then
Cells(i, "I").Interior.ColorIndex = 44
End If
Next
'ActiveSheet.Protect Password:="QC"
End Sub
Your loops Do...Loop Until (condition) are running at least once and the condition is checked at the end of the loop. You can use Do Until (condition)...Loop loop instead. In that case condition is checked at the beginning and if it's true already, then loop will not run.
I am able to get the result that I want to get with my code which is as follows:
Sub Button1_Click()
With Worksheets("Data").Select
With Range("A11:H11").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
With Range("E11").Select
ActiveCell.FormulaR1C1 = "Seasonal Items"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
End Sub
This code is not very elegant nor is it flowing really.
What I would like it to do is automatically search for specific wording in the column B which is either Fan or Heater, then move it to the bottom, where it is separated with a row that states season items.
See the picture below of the result:
Why I want it different is due to that the stuff is flowing and changing at points... It would make it simpler and I also would like the code to be much shorter and not for me to each time physically having to check and edit the code before running it...
Thank you for taking the time to view this and if possible provide a solution.
Something like this will move the rows the way you want them, but you will need to add in the specific formatting yourself.
Sub test()
Dim lRow As Integer
Dim lrow2 As Integer
Dim i As Integer
lRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row
ActiveSheet.Cells(lRow + 1, 5).Value = "Seasonal Items"
With ThisWorkbook.ActiveSheet
For i = 2 To lRow
lrow2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row + 1
If InStr(.Cells(i, 2), "Fan") > 0 Or InStr(.Cells(i, 2), "Heater") > 0 Then
.Rows(lrow2 & ":" & lrow2).Value = .Rows(i & ":" & i).Value
.Rows(i & ":" & i).ClearContents
End If
Next i
For i = 2 To lrow2
If .Cells(i, 1).Value = "" Then
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With
End Sub
I am having trouble understanding what the below function is doing.
The function itself has the ability to copy data to the sheet Sheet History. However, I do not get how it is doing it?
Sub histFunc()
Dim Y As String
Y = "R" & Range("G7").Value
Sheets("Sheet History").Select
Range("h17").Select
Cells.Find(What:=Y, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Sheet Current").Select
End Sub
Any suggestions how this macro is operating?
I appreciate your replies!
In short, the code searches for the value in G7 in Sheet History and replaces the right part of that line with values only, i.e. removing references or values.
Step-by-step Explanation
Get the value of cell G7:
Y = "R" & Range("G7").Value
Select sheet Sheet History and select cell H17:
Sheets("Sheet History").Select
Range("h17").Select
Executes the Find method over Cells, all cells in the sheet (note that if no parameter is given it is the range of all Cells in the current Sheet):
Cells.Find(What:=Y, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
This returns:
A Range object that represents the first cell where that information is found.
For more info see the Find documentation.
Now due to .Activate the (first) cell is selected where the value was found. This selection is extended to the end of the line:
Range(Selection, Selection.End(xlToRight)).Select
Then the CutCopyMode is deactivated to clear the clipboard after usage:
Application.CutCopyMode = False
Now the selected cells are copied and pasted:
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Note that they are pasted on with PasteSpecial on the same location, using xlPasteValues to only maintain the values, and therefore not to have any formulas nor references in the cells.
Now go to Sheet Current:
Sheets("Sheet Current").Select
After a bit of cleaning, this is what this could look like (explanations below) :
Sub histFunc()
Dim FindRange As Range, _
LookForValue As String
LookForValue = "R" & Range("G7").Value
With Sheets("Sheet History")
.Range("h17").Activate
Set FindRange = .Cells.Find(What:=LookForValue, _
After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
Application.CutCopyMode = False
Range(FindRange, FindRange.End(xlToRight)).Copy
FindRange.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
End With
Application.CutCopyMode = False
Sheets("Sheet Current").Select
End Sub
I changed Y to LookForValue for better understanding and used a Range variable to reference the result of the Find method.
So this code, step by step :
Define LookForValue as "R" & Range("G7").Value
Search for that value in the formulas of Sheet History
Copy the data block (in the row of the result, from result to right, until there is a blank)
Paste it at the same place but in values, so that you get rid of the formulas!
I want a macro that will copy all rows in one sheet that have a certain name in them to a separate sheet.
My plan is to do it as a loop that stops when it can not find any more of the name. The problem is I can't figure out how to make the loop stop when the search fails when it has found all the occurrences.
Here is my code that loops 10 times. It works just fine except that I want to fix it so that it loops however many it takes and then stops. This could be anywhere from 0 times to 500 times.
By the way, the values I search for are in 3 different columns side by side.
I would really like to change the code as little as possible as I don't know VBA well and would like to avoid doing a lot of learning that I will be unlikely to use again.
Dim Counter As Integer
Range("A1").Select
' Start the loop that I want changed to stop automatically:
Do While Counter < 10
Cells.Find(What:="matt johnson", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
' go to destination sheet:
Sheets("Matt").Select
ActiveCell.SpecialCells(xlLastCell).Select
ActiveCell.Offset(1, 2).Range("A1").Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
' go back to source sheet:
ActiveCell.Offset(1, 0).Range("A1").Select
Sheets("Upcoming Deadlines").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 26).Range("A1").Select
Application.CutCopyMode = False
Counter = Counter + 1
Loop
End Sub
I think this will solve your problem with minimal changes:
Sub test()
Dim Counter As Integer
Range("A1").Select
' Start the loop that I want changed to stop automatically:
Do Until Cells.Find(What:="matt johnson", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False) Is Nothing
Cells.Find(What:="matt johnson", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Copy
' go to destination sheet:
Sheets("Matt").Select
ActiveCell.SpecialCells(xlLastCell).Select
ActiveCell.Offset(1, 2).Range("A1").Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
' go back to source sheet:
ActiveCell.Offset(1, 0).Range("A1").Select
Sheets("Upcoming Deadlines").Select
ActiveCell.Offset(0, 1).Range("A1").Select
Selection.End(xlToRight).Select
ActiveCell.Offset(0, 26).Range("A1").Select
Application.CutCopyMode = False
Counter = Counter + 1
Loop
End Sub
Explanation
This will continue to loop until the search finds nothing.