I have certain values in my column A.
For exapmple:
Header
A
A
C
C
D
D
E
F
I want to keep rows having D and remove all other. As a first step, Have sorted my sheet.
Now trying below code but its giving error of
Invalid or unqualified reference
Dim strA As Range
Dim strB As Range
Range("A:A").Select
Selection.Find(What:="D", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(-1, 0).Select
Set strA = .ActiveCell
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, ActiveCell.Offset(1, 0).Select).Select
ActiveCell.Offset(1, 0).Select
Set strB = .ActiveCell
Range(strA, strB).Select
End Sub
Maybe something like this :
Sub test()
n = Application.WorksheetFunction.CountIf(Range("A:A"), "D")
Set c = Range("A:A").Find("D", lookat:=xlWhole)
Range("A" & c.Row, Range("E" & c.Row).Offset(n - 1, 0)).Copy Destination:=Range("A2") 'change E as needed, depends how many column is your data
Set rngDel = Range("A1").Offset(n + 1, 0)
Range(rngDel, rngDel.End(xlDown)).EntireRow.Delete
End Sub
Before running the code, the data table must be sort first by column A.
The code will count how many "D" are there in column A.
Then it get the cell where it find the first "D"
From there it copy all the cells which has "D" value
then paste it to cell A2
lastly, it delete the remaining cells which doesn't have "D" value
Related
I am interested in doing this: IF Cell C14 = Cell $C$8, THEN keep the cell value BUT remove the IF formula. For rest of the Cells in Column C with IF Formula (False condition: "InsertText!"), retain the IF formula
Refer to Image here
I've tried multiple ways of phrasing the VBA syntax but I'm not getting the desired result.
Sub convertToValue()
Dim totRow As Long
Dim rng As Range
' Find row with word InsertText in it
totRow = Cells.Find(What:="InsertText", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Row
Set rng = Rows("C:C")
rng.Copy
rng.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub
Is there a way to do this? Thanks!
This works for me with my test spreadsheet.
Sub convertToValue()
LastRow = ActiveCell.SpecialCells(xlLastCell).Row
' change the 13 in the line below to whichever row the data
' actually starts on (the one after the table header)
For Row = 13 To LastRow
Set CurrentCell = Range("C" & Row)
' do the copy/paste only if the current cell is a
' formula AND it doesn't evaluate to "Insert Text"
If Left(CurrentCell.Formula, 1) = "=" And CurrentCell.Value2 <> "Insert Text" Then
Range("C8").Copy
CurrentCell.PasteSpecial Paste:=xlPasteValues
End If
Next
Range("C3").Select
End Sub
If you assign it to a button then you can set the product, enter new details, push the button, and repeat.
I'm writing a macro to search for 3 values in 3 columns on one worksheet. I'm fairly new to vba and need some assistance please. I have 3 values on worksheet "Data" in columns C, D and E which I need to find on worksheet "First" in columns C,D and E. Column C is sorted in numeric order.
So far I have a code that finds the value of C1 on the "Data" worksheet, in column C on the "First" worksheet. It then copies the data of the first line on the "Data" worksheet and inserts it under the active cell found in column C on the "First" worksheet. If value is not found on "First" worksheet, the code pastes the line at the bottom of data on worksheet "First". The problem is, my code finds the first occurence of C1 on "First" worksheet and inserts the line from "Data" worksheet underneath the active cell, but then D1 and E1 is not in numerical order.
This is what I have:
Sub Blank1()
Dim c As Range
Dim Source As Worksheet
Dim Target As Worksheet
Set Source = ThisWorkbook.Worksheets("Data")
Set Target = ThisWorkbook.Worksheets("first")
Set c = Source.Range("C1")
Set c = Target.Range("C:C").Find(what:=c.Value, LookIn:=xlFormulas,
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False, SearchFormat:=False)
Sheets("Data").Select
Range("C1").Select
If Not c Is Nothing Then
c = ActiveCell.Value
Sheets("first").Select
Columns("C:C").Select
Selection.Find(what:=c, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Select
Else
Sheets("first").Select
Range("B1").Select
Range("B1").End(xlDown).Offset(1, 0).Select
Selection.End(xlToLeft).Offset(0, 0).Select
End If
Sheets("Data").Select
Rows("1:1").Select
Selection.Cut
Sheets("first").Select
ActiveCell.Offset(1).EntireRow.Insert Shift:=xlShiftDown,
CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.EntireRow.Copy
ActiveCell.Offset(1).EntireRow.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Sheets("Data").Select
Selection.Delete Shift:=xlUp
Range("C1").Select
End Sub
I expect to insert values numerically on "First" worksheet. I also want it to loop through all values in C column on "Data" Worksheet.
I want to implement a VBA Code to work with multiple different sheets, for example: it starts by looking for a certain number in the first row, once it's found, it jumps to that column and types a certain formula into the 2nd cell in that column, so far it works good, But the issue is that I wanna make it to Autofill that formula down the column if the first cell in that row contains data.
Like if A2 is not blank, continue the auto fill the cell in the active column (let's say the active column is D, then the it would fill the Cell d2 if a2 not blank) and stops once the cell in A Column is blank .. etc
So, Is it possible?
Sub Macro1()
Rows("1:1").Select
Selection.Find(What:="156", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
ActiveCell.Offset(1).Select
ActiveCell.FormulaR1C1 = _
"= "Formula will be here""
End Sub
Might be best to save a copy of your workbook before running the code below.
Maybe something like this is what you're after. If Find found something in column D, then it puts the dummy formula in the range D2:D?, where ? is whatever the last row in column A is (which I think is what you described).
Option Explicit
Sub Macro1()
Dim ws As Worksheet
Set ws = ActiveSheet ' Can you refer to the workbook and worksheet by name? Please do if possible
With ws
Dim cellFound As Range
Set cellFound = .Rows(1).Find(What:="156", LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=False)
If cellFound Is Nothing Then
MsgBox ("The value was not found in the first row of sheet '" & ws.Name & "'. Code will stop running now")
Exit Sub
End If
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range(cellFound.Offset(1), .Cells(lastRow, cellFound.Column)).FormulaR1C1 = "=""Formula will be here"""
End With
End Sub
Check this simple code, I think it will satisfy your needs:
Sub Macro1()
Rows("1:1").Select
Selection.Find(What:="156", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False).Activate
col_Num = ActiveCell.Column
total_Rows = WorksheetFunction.CountA(Range("A:A"))
Cells(2, col_Num).Select
Cells(2, col_Num) = "=Put your Formula here"
begin_Cell = Cells(2, col_Num).Address(False, False)
end_Cell = Cells(total_Rows, col_Num).Address(False, False)
Selection.AutoFill Destination:=Range(begin_Cell & ":" & end_Cell)
End Sub
There are easier ways to locate a column header label although I'm unclear on why you are using the LookAt:=xlPart argument. It seems to me you should not have to 'wildcard' the search but a 'wild card' search can be accommodated.
Sub FindnFill()
dim m as variant
with worksheets("sheet1")
m = application.match("*156*", .rows(1), 0)
if not iserror(m) then
if not isempty(.cells(2, "A")) then
.range(.cells(2, m), .cells(.rows.count, "A").end(xlup).offset(0, m-1)).formula = _
"=""formula goes here"""
else
.cells(2, m).formula = _
"=""formula goes here"""
end if
end if
end with
end sub
Find & Fill
About the Find Method
It is best practice to always set the following three parameters, because they
are saved each time they are used.
LookIn - If you use xlFormulas, it will find e.g. =A2 + 156, which you don't want.
LookAt - If you use xlPart it will find e.g. 1567, which you don't want.
SearchOrder - Not important, since a row is being searched.
Additionally SearchDirection is by default xlNext and can therefore safely be omitted.
Additionally MatchCase is by default False and can therefore safely be omitted.
Additionally SearchFormat - To use it you previously have to set Application.FindFormat.NumberFormat and can therefore safely be omitted.
The Code
Sub FindFill()
Const cDblFind As Double = 156 ' Found Value
Const cLngRow As Long = 1 ' Found Row Number
Const cVntColumn As Variant = "A" ' First Column Letter/Number
Const cStrFormula As String = "=RC[-1]+5" ' Formula
Dim objFound As Range ' Found Column Cell Range
Dim lngRow As Long ' First Column Non-empty Rows
With ActiveSheet.Rows(cLngRow)
' Check if cell below cell in First Column and Found Row is empty.
If .Parent.Cells(cLngRow, cVntColumn).Offset(1, 0).Value = "" Then Exit Sub
' Calculate First Column Non-empty Rows.
lngRow = .Parent.Cells(cLngRow, cVntColumn).End(xlDown).Row - cLngRow
' Find cell in Found Row containing Found Value.
Set objFound = .Find(What:=cDblFind, After:=.Cells(.Row, .Columns.Count), _
LookIn:=xlValues, LookAt:=xlWhole, Searchorder:=xlByRows)
If Not objFound Is Nothing Then
' Write Formula to Found Column Range
objFound.Offset(1, 0).Resize(lngRow).FormulaR1C1 = cStrFormula
End If
End With
End Sub
I'm trying to write code which automates something: I've got a table of data which I need to add a column into, then put a sum in which goes all the way down to the bottom row of data and no further. I know how to define the bottom row as a variable; but what if the column I'm entering the data can vary too? In my example, the column I want to do the sums in is always to the left of the column entitled '16'. It will always start at row 2, but it won't always be column O. It might be column P, or Q, for example.
Sub enter_column_and_add_calculations()
Dim NBottomrow
Call find_bottom_row
NBottomrow = ActiveCell.Row
'find column entitled '16':
Range("A1").Select
Cells.Find(What:="16", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=False _
, SearchFormat:=False).Activate
'insert new column to the left:
Selection.EntireColumn.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
'insert text in the cell:
ActiveCell.FormulaR1C1 = "OOT Debt"
'offset one cell below:
ActiveCell.Offset(1, 0).Range("A1").Select
'i'm now in the cell i want my range to start at. In this example it's cell O2, but it often varies:
ActiveCell.FormulaR1C1 = "=SUM(RC[1]:RC[5])"
Selection.AutoFill Destination:=Range("O2:O" & NBottomrow)
End Sub
Private Sub find_bottom_row()
Range("A1").Select
Selection.End(xlDown).Select
End Sub
Many thanks for your help :-)
Try,
Sub enter_column_and_add_calculations()
dim m as variant, lr as long
with worksheets("sheet1")
m = application.match(16, .rows(1), 0)
if iserror(m) then exit sub
lr = .cells(.rows.count, m).end(xlup).row
.cells(lr+1, m).formula = "=sum(" & .range(.cells(2, m), .cells(lr, m)).address(0,0) & ")"
end with
end sub
I am trying to write a macro for excel that searches Sheet1 and
finds all instances of the words Force and Grade, then
copies the cells beneath those words (all cells to the first empty row), and pastes to Sheet2.
These words (Force and Grade) can be found in any cell in Worksheet1 and the size of the used area changes every time the file is created.
So far, I can only get it to find the first instance of each word. I have tried many types of loops from examples on this website and others.
I feel like this should be simple, so I am not sure why I can't find the solution. I have tried a For Next Loop that starts with For i To ws.Columns.Count (with "ws" set to Sheet1), but it turns into an infinite loop (although the total column count was only around 15). Any help or nudge in the right direction would be appreciated.
Here is the code that works so far:
my code
'COPY AND PASTE ALL FORCE VALUES TO FROM SHEET1 TO SHEET2
Sheets("Sheet1").Select
Cells.Find(What:=strSearch1, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Activate 'select cell below the word "Force"
Range(ActiveCell, ActiveCell.End(xlDown)).Select 'select all cells after "Force" to first empty cell
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Cells(Selection.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Select 'paste to next column
ActiveSheet.Paste
You should use FindNext to indentify all the matches. Something like this to copy all cells below all instances of Force to column A of Sheet2
Dim StrSearch As String
Dim rng1 As Range
Dim rng2 As Range
StrSearch = "Force"
With Worksheets(1).UsedRange
Set rng1 = .Find(StrSearch, , xlValues, xlPart)
If Not rng1 Is Nothing Then
strAddress = rng1.Address
Set rng2 = rng1
Do
Set rng1 = .FindNext(rng1)
Set rng2 = Union(rng2, rng1)
Loop While Not rng1 Is Nothing And rng1.Address <> strAddress
End If
End With
If Not rng2 Is Nothing Then
For Each rng3 In rng2
Range(rng2.Offset(1, 0), rng3.End(xlDown)).Copy Sheets(2).Cells(Rows.Count, "A").End(xlUp)
Next
End If
With Worksheets(1).UsedRange
'Code to copy and paste Force values
Set rng1 = .Find(strSearch1, LookIn:=xlValues)
SampleCnt = Application.WorksheetFunction.CountIf(Sheets("Sheet1").Range("A1:BJ2000"), "Grade")
Do While i < SampleCnt
rng1.Offset(1, 0).Activate 'select cell below the word "Force"
Range(ActiveCell, ActiveCell.End(xlDown)).Select 'select all cells after "Force" to first empty cell
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Worksheets("Sheet2").Columns(Cnt).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Set rng1 = .FindNext(rng1)
Cnt = Cnt + 2
i = i + 1
Loop
'Code to copy and paste Grade values
Cnt = 4
i = 0
Set rng2 = .Find(strSearch2, LookIn:=xlValues)
Do While i < SampleCnt
rng2.Offset(1, 0).Activate 'select cell below the word "Grade"
Range(ActiveCell, ActiveCell.End(xlDown)).Select 'select all cells after "Grade" to first empty cell
numBonds = Range(ActiveCell, ActiveCell.End(xlDown)).Count
Selection.Copy
Sheets("Sheet2").Select
Worksheets("Sheet2").Columns(Cnt).Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Set rng2 = .FindNext(rng2)
Cnt = Cnt + 2
i = i + 1
Loop
End With