I have values in this "Sample Analysis Data" sheet in the range B2:B10.
For each cell in the range, the code looks for that value in the sheet "Meta Data". It then copies the cells in that row and pastes it in "Sample Analysis Data" (to the right of the searched value). This works for the value in B2.
I can't get it to move on to B3 and then B4 and such. It loops though and does the same thing again for B2.
What do I need to do to get it to loop to from B2 through to B10?
Along with this, how do I get it to go from B2 to the last entry in the column (as each data set I work with could have a different number of rows of data,) not just to B10?
Sub GetMetaData()
Worksheets("Sample Analysis Data").Activate
Range("B2").Select
Dim srch As Range, cell As Variant
Set srch = Range("B2:B10")
For Each cell In srch
Sheets("Meta Data").Activate
Cells.Find(What:=cell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
ActiveSheet.Cells(ActiveCell.Row, 1).Select
Range(ActiveCell, ActiveCell.End(xlToRight).End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sample Analysis Data").Activate
ActiveCell.Offset(0, 7).Select
ActiveSheet.Paste
Next cell
End Sub
Try this?
Change the i=8 to however many cells you need to offset (you indicated B2:B10, which is 8)
Sub testcopy()
Dim srch As Range, metarg As Range, rg As Range, pstrg As Range
Dim i As Long
Dim ws As Worksheet, ws2 As Worksheet
Set ws = ThisWorkbook.Sheets("Sample Analysis Data")
Set ws2 = ThisWorkbook.Sheets("Meta Data")
Set metarg = ws2.Range("A1:A100") 'range that includes the key that you are searching in B2:B10
Set srch = ws.Range("B1") 'i'm offsetting, so i'm going back one row
For i = 1 To 8 'change 8 to how many cells to offset
Set rg = metarg.Find(srch.Offset(i, 0).Value, LookIn:=xlValues, lookat:=xlWhole) 'find the value in meta sheet
If Not rg Is Nothing Then
Set pstrg = ws2.Range(rg, ws2.Cells(rg.Row, rg.End(xlToRight).Column))
pstrg.Copy
srch.Offset(i, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
Next i
End Sub
Related
I have this data
This code grabs column "BO" and copies it to the right.
I need a repeatable macro that copies column BK and inserts it to the right, which pushes the blank space & totals over. I am putting this on a button so I can repeat the add column.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rLastCell As Range
Dim LastCol As Integer
Set rLastCell = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
LastCol = rLastCell.Column
ws.Columns(LastCol).Copy ws.Columns(LastCol + 1)
End Sub
This looks like it'll do the job.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rLastCell As Range
Dim LastCol As Integer
Set rLastCell = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
LastCol = rLastCell.Column ws.Columns(LastCol - 4).Copy
ws.Columns(LastCol - 3).Insert shift:=xlToRight
End Sub
I guess, the request is, that Jeff wants to copy the column he thinks, it's the last one immediately right to it.
But the problem is, that often Excel considers a different column as last one than the user: If a cell e.g. contains a formula where the result is nothing, the cell is empty for the user, but not for Excel. So it's not so easy to figure out the last column.
One workaround I would suggest is: Select a cell in the column you think, it's the last one, start the macro that copies the selected column right to it:
Sub CopyColumnToTheRight()
Dim ThisCol As Integer, ThisRow As Long, CurS As Worksheet, IsOk As Boolean
Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
IsOk = IsEmpty(CurS.Cells(ThisRow, ThisCol + 1))
If IsOk Then 'just to prevent to start the macro on the wrong column
CurS.Columns(ThisCol).Copy
CurS.Columns(ThisCol + 1).Insert Shift:=xlToRight
CurS.Cells(ThisRow, ThisCol + 1).Select
Else
Beep
End If
End Sub
What you ask is much more simple than what you have!
Look at the needed code
Sub Test()
Dim ws As Worksheet,rLastCell as range, LastCol as long
Set ws = ActiveSheet
Set rLastCell = ws.Cells.Find(What:="*", After:=ws.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _ xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
LastCol = rLastCell.Column
ws.Columns(LastCol-3).copy
ws.Columns(LastCol-2).insert shift:=xlToRigh
End Sub
Somehow it was not clear to me that you have 3 more columns to the right.
The 'IsOk' simply checks, if the cell right of the selected is empty to avoid to run this macro in the wrong column.
If you replace it with
IsOk = IsEmpty(CurS.Cells(ThisRow, ThisCol + 4))
it checks, if the cell in the column 4 more right (after your 3 summary columns) is blank.
IsOk = CurS.Cells(ThisRow, ThisCol + 1).HasFormula
checks, if the cell right of you has a formula. This version will also work, if you add more columns with formulas to the right
IsOk = True
Disables this feature, you can insert the new column all over the entire sheet.
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 have run a macro to paste, edit, alter and split data using a specified data set.
On a new data set (more data) I ran into a problem with my data range.
ActiveSheet.Range("$A$1:$T$299").AutoFilter Field:=6, Criteria1:= _
"=Site Reference A", Operator:=xlOr, Criteria2:= _
"=Site Reference A Total"
Range("A1:T299").Select
Range("F160").Activate
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
My data range is $A$1:$T$299. How would I make this dynamic?
Example -
Data set A has 200 columns.
Data set B has 230 columns.
A little long, but this full code is the safer way to find the last row and last column in a sheet.
Dim Sht As Worksheet
Dim FiltRng As Range
Dim LastCol As Long
Dim LastRow As Long
Set Sht = ActiveSheet '<-- better not rely on ActiveSheet
LastRow = FindLastRow(Sht)
LastCol = FindLastCol(Sht)
With Sht
Set FiltRng = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)) ' <-- set the filtered range dynamically
End With
With Sht
FiltRng.AutoFilter Field:=6, Criteria1:= _
"=Site Reference A", Operator:=xlOr, Criteria2:= _
"=Site Reference A Total"
' rest of your code goes here
End With
'==========================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
'==========================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.Row
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
If there is no other data in column A, you can use a dynamic named range. Just use the following formula as the range for your named range and then reference the named range in your code. Keep in mind that this only works if there is no other data in column A.
=OFFSET($A$1,0,0,COUNTA($A:$A),1)
I have a Excel workbook (lets call serial_numbers) that contains a list of S/N on A1 to A10 (can be more or less).
Now I have to search for A1's value on workbook "database". That value is usually found in A1 cell of workbook "database".
In case that I find A1's valueI need to copy and paste B2's value of workbook "database", which cointains the current stock of that value.
Through Developer mode on Excel I got the following result:
Sub Macro1()
'
' Check stock for S/N in database
'
'
Range("A1").Select
Selection.Copy
Workbooks.Open Filename:="database.xlsx", _
UpdateLinks:=0
Range("A1").Select
Selection.Find(What:="XXXXXX", After:=ActiveCell, LookIn:=xlFormulas _
, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range("B1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("serial_numbers.xlsx").Activate
Range("B1").Select
ActiveSheet.Paste
End Sub
That piece above seems to be not working properly and since Im new to this I cant get why. Can any of you help me?
If you are looking for non-vba solution then you may go for vlookup function.
Try this code :
Sub testMacro()
Dim wkbDB As Workbook
Dim rngFind As Range, rngSearch As Range, cell As Range
Dim shtDB As Worksheet
Set wkbDB = Workbooks.Open(Filename:="C:\database.xlsx", UpdateLinks:=0)
Set shtDB = wkbDB.Sheets("Sheet1")
Set rngSearch = ThisWorkbook.Sheets("Sheet1").Range("A1:A10")
For Each cell In rngSearch
Set rngFind = shtDB.Range("A1:A10").Find(What:=cell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows)
If Not rngFind Is Nothing Then
'serial_numbers.xlsx
cell.Offset(0, 1) = rngFind.Offset(0, 1)
End If
Next
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