I want to search a specified column for a String value. Then I want to grab the six values to the right of that column value. I am currently doing it like this which is working correctly.
Set c = wsSrc.Columns(col).Find(What:="DSCR Analysis", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
Note here are the declarations for the following variables.
Property Get wsSrc() As Worksheet
Set wsSrc = ActiveWorkbook.Sheets("MBI DSCR")
End Property
Property Get wSrc() As Workbook
Set wSrc = ActiveWorkbook
End Property
Property Get col() As Long
col = wsSrc.Columns.Find(What:="MBI", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Column
End Property
Property Get col2() As Long
col2 = wSrc.Sheets("Inputs").Columns.Find(What:="Deal Team", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Column
End Property
Property Get wsDest() As Worksheet
Set wsDest = Workbooks("LBM_DSCT_DataLake.xlsm").Worksheets("Sheet1")
End Property
Currently I am copying a specified value from the source sheet then pasting it to the destination sheet over and over for all the different values I want to copy.
However I am wondering if it is possible to copy all the different values (ie "DSCR Analysis") to a clipboard and then paste. So the program does not "jump" back and forth between sheets rather grabs all the data it needs once, copies it, then pastes it in the destination sheet.
Below is an example of how one of my functions works wit hthe copying and pasting. I have around 20 of these where the program jumps back and forth.
Sub PasteCI()
Dim c As Range, cDest As Range
Set c = wsSrc.Columns(col).Find(What:="Commercial Income", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
Set cDest = wsDest.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0) 'next paste destination. C2?
If c Is Nothing Then 'didn't make a match with Find() ?
cDest.Resize(6, 1).Value = "-" 'fill placeholders
Else
c.Offset(0, 1).Resize(1, 6).Copy 'got match - copy range
cDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End If
End Sub
Related
Hi I am creating a program which copys data from the source workbook and pastes it to another. However, in the way I have currently programed it, the active workbook/worksheet is changing as I am pasting data into the following sheet.
Below is an example of how I have set the source workbook and how I am calling it.
Property Get wsSrc() As Worksheet
Set wsSrc = ActiveWorkbook.Sheets("MBI DSCR")
End Property
Property Get wSrc() As Workbook
Set wSrc = ActiveWorkbook
End Property
The source book is called by...
Property Get col2() As Long
col2 = wSrc.Sheets("Inputs").Columns.Find(What:="Deal Team", LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False).Column
End Property
Property Get wsDest() As Worksheet
Set wsDest = Workbooks("destBook.xlsm").Worksheets("Sheet1")
End Property
Then the code is called in the following example
Sub PasteCI()
Dim c As Range, cDest As Range
Set c = wsSrc.Columns(col).Find(What:="Commercial Income", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
Set cDest = wsDest.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0) 'next paste destination. C2?
If c Is Nothing Then 'didn't make a match with Find() ?
cDest.Resize(6, 1).Value = "-" 'fill placeholders
Else
c.Offset(0, 1).Resize(1, 6).Copy 'got match - copy range
cDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End If
End Sub
Is there a way to keep the source sheet constant, ie when the active workbook is set all callings to wSrc is to the initial active workbook?
I want to go into a sheet and look for a value. If the value is there I want to grab the data in its row and paste transposed in another sheet. This function is working.
However, if the value in the column is not there I want to paste filler text into the column where the data would otherwise go.
I am getting a "Type Mismatch" error when I run the following code. What is going wrong/ how can I made this happen.
Dim c As Long
Windows("WBGrab").Activate '-> opens doc we want to look a
c = Sheets("SheetName").Columns(2).Find(What:="Commercial Income", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
If c Is Nothing Then
Windows("WBPaste").Activate
Range("C2:C7").Value = "-"
Else
Sheets("SheetName").Range("C" & c & ":H" & c).Select '-> opens MBI DSCR sheet and copes naming & values
Selection.Copy '-> copies the selected area
Windows("WBPaste").Activate '-> opens back up the data lake
Sheets("Sheet1").Range("C" & 2).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=True
End Sub
If Find() fails to make a match then your code will error before getting to If c Is Nothing Then because of the .Row tagged onto the Find() line.
Something like this should work:
Sub Tester()
Dim c As Range, wsSrc As Worksheet, wsDest As Worksheet, cDest As Range
'set up source and destination sheets
Set wsSrc = Workbooks("WBGrab").Worksheets("SheetName") 'add the file extension to the name
Set wsDest = Workbooks("WBPaste").Worksheets("Sheet1")
Set c = wsSrc.Columns(2).Find(What:="Commercial Income", LookIn:=xlValues, _
LookAt:=xlPart, MatchCase:=False)
Set cDest = wsDest.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) 'next paste destination. C2?
If c Is Nothing Then 'didn't make a match with Find() ?
cDest.Resize(1, 7).Value = "-" 'fill placeholders
Else
c.Offset(0, 1).Resize(1, 7).Copy 'got match - copy range
cDest.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=True
End If
End Sub
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 two sheets:
Database
Macro sheet: It has a row with dates that will be the headings of a table after the macro.
Objective: In the macro sheet take the value of the first date and look for its position in the database sheet. Then, in the database sheet, copy the entire column corresponding to the previously copied date.
I understand that the code should look something like this:
Sheets("Macro").Select
Range("K3").Select
Selection.Copy
Sheets("Database").Select
Cells.Find(What:=Selection.PasteSpecial xlValues, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Macro").Select
ActiveSheet.Paste
This code does not work, because the search part is not done well, I will appreciate some correction
Something along these lines.
Read this to learn the advantages of not using Select or Activate.
When using Find, always check first that your search term is found to avoid an error. For example, you cannot activate a cell that does not exist.
Sub x()
Dim r As Range
With Sheets("Database")
Set r = .Cells.Find(What:=Sheets("Macro").Range("K3").Value, lookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not r Is Nothing Then
Range(r, r.End(xlDown)).Copy Sheets("Macro").Range("A1")
End If
End With
End Sub
Loop through he header dates in the Macro worksheet. If any can be found in the header row of the Database worksheet, copy that column to the Macro worksheet under the header.
sub getDateData()
dim h as long, wsdb as worksheet, m as variant, arr as variant
set wsdb = worksheets("database")
with worksheets("macro")
for h=1 to .cells(1, .columns.count).end(xltoleft).column
m = application.match(.cells(1, h).value2, wsdb.rows(1), 0)
if not iserror(m) then
arr = wsdb.range(wsdb.cells(2, m), wsdb.cells(rows.count, m).end(xlup)).value
.cells(2, h).resize(ubound(arr, 1), ubound(arr, 2)) = arr
end if
next h
end with
end sub
I am trying to select columns based on their heading value and then move them over to the end on the right. I know it is selecting the columns correctly, and identifying the next empty column. However, when running the code, it'll get down to the emptyRange.select.offset and then gives an error saying an object is required.
I'm not sure if I am overcomplicating this code.
Sub colShift()
Dim dCol As Range
Dim qCol As Range
Dim emptyRange As Range
With Sheets("Data")
Set dCol = Range( _
Range("A1:ZZ1").Find(What:="name_a", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False), _
Range("A1:ZZ1").Find(What:="name_a", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False).End(xlDown))
Set qCol = Range( _
Range("A1:ZZ1").Find(What:="name_b", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False), _
Range("A1:ZZ1").Find(What:="name_b", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False).End(xlDown))
End With
For Each cell In Range("A1:ZZ1")
cell.Activate
If IsEmpty(cell) = True Then
Set emptyRange = ActiveCell
Exit For
End If
Next cell
dCol.Select
Selection.Cut
emptyRange.Select.Offset
Selection.Insert Shift:=xlToRight
For Each cell In Range("A1:ZZ1")
cell.Activate
If IsEmpty(cell) = True Then
Set emptyRange = ActiveCell
Exit For
End If
Next cell
qCol.Select
Selection.Cut
emptyRange.Select
Selection.Insert Shift:=xlToRight
End Sub
Sloppy solution below
Sub colShift()
Dim dCol As Range
Dim qCol As Range
Dim emptyRange As Range
Dim MyRange As Range
Dim iCounter As Long
With Sheets("Data")
Set dCol = Range( _
Range("A1:ZZ1").Find(What:="name_a", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False), _
Range("A1:ZZ1").Find(What:="name_a", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False).End(xlDown))
Set qCol = Range( _
Range("A1:ZZ1").Find(What:="name_b", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False), _
Range("A1:ZZ1").Find(What:="name_b", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:= _
xlWhole, MatchCase:=False).End(xlDown))
End With
For Each cell In Range("A1:ZZ1")
cell.Activate
If IsEmpty(cell) = True Then
Set emptyRange = ActiveCell
col = ActiveCell.Column
Exit For
End If
Next cell
dCol.Select
Selection.Cut
Cells(1, col).Select
ActiveSheet.Paste
'Blank Column Deleter
Set MyRange = ActiveSheet.UsedRange
For iCounter = MyRange.Columns.Count To 1 Step -1
If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
Columns(iCounter).Delete
End If
Next iCounter
'
For Each cell In Range("A1:ZZ1")
cell.Activate
If IsEmpty(cell) = True Then
Set emptyRange = ActiveCell
col = ActiveCell.Column
Exit For
End If
Next cell
qCol.Select
Selection.Cut
Cells(1, col).Select
ActiveSheet.Paste
'Blank Column Deleter
Set MyRange = ActiveSheet.UsedRange
For iCounter = MyRange.Columns.Count To 1 Step -1
If Application.CountA(Columns(iCounter).EntireColumn) = 0 Then
Columns(iCounter).Delete
End If
Next iCounter
End Sub
Couple of problems I see.
1) You are not checking if emptyRange is allocated with an object reference before trying to access it. Now, your worksheet might never have a data width that exceeds column "ZZ", but that is not good practice. That could be your problem, but it might not be - I wouldn't be able to tell without seeing your data.
2) I don't see what you are trying to do there with Offset. You haven't specified an argument for rows up/down or columns left/right so it's really not doing anything. Also, I don't think you can use it after a select statement like that. If you wanted to do that you would do:
emptyRange.Select
Selection.Offset(0,1) `this would offset one column - not sure what you wanted to do
But that whole selection step is unnecessary as you can work with the object directly:
emptyRange.Offset(0,1)
As to whether or not you're overcomplicating things: yes - you can simplify this code quite a bit by getting rid of all the Activate & Select methods and just working with the objects directly.
Instead of looping over all the cells in A1:ZZ1, just use the Find method again. The other benefit of this, is that using find as I've done below will always return an object (in excel 2007 and up) so you won't need a check like I mentioned above.
I don't particularly like the use of two find statements to create a range of used data for dCol and qCol - I found it difficult to read and interpret what you were doing. Here again I wouldn't use a fixed sized range as I mentioned above - this makes your code more fragile. I actually think it's a lot easier to read and understand if you break this into two operations: 1) find the column, 2) resize the range down to the last row in the column
You can avoid a second loop by using Offset to just move over one column, and you can eliminate the insert line by providing the destination argument for cut.
EDIT after OP posted "sloppy solution":
You can greatly simplify the code by just selecting the entire column and inserting it before the last empty column. You then don't need any routine to cleanup blank columns.
Sub colShift()
Dim dCol As Range
Dim qCol As Range
Dim destination As Range
With Sheets("Data").Cells
'Find the cell in row 1 which contains "name_a"
Set dCol = .Find(What:="name_a", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False).EntireColumn
'Repeat same steps for qCol
Set qCol = .Find(What:="name_b", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False).EntireColumn
'Find the last column which has data in it, and get the next column over (the first empty column)
Set destination = .Find("*", .Cells(1, 1), xlFormulas, xlPart, xlByColumns, xlPrevious).Offset(0, 1).EntireColumn
End With
'Insert dCol before the first empty column at the end of the data range:
dCol.Cut
destination.Insert shift:=xlShiftToRight
'Insert qCol before that same empty column
qCol.Cut
destination.Insert shift:=xlShiftToRight
End Sub