I am creating a monthly report that copies cell values and pastes them onto specific rows depending on some simple criteria.
Pre Filter
I already have a IF function that =1 if my conditions are met. This is located in column C.
My goal is to copy 5 cells and simply paste-values them in the row that the filter = 1.
The following VBA has been myself playing with the option to filter to only show that specific row that =1, and then selection the 'Criteria 1', to paste in the first visible row below
Post Filter
Sub Macro11()
'
' Macro11 Macro
'
Dim PasteCell As Range
Set PasteCell = Range("F2").Offset(1, 0).Value 'F2 is the header for Criteria 1'
'Copy values from plan
ThisWorkbook.Worksheets("MonthlyDump").Range("N1:R1").Select
Selection.Copy
'Filter to only show the IF function = 1, plus blanks so the headings still show
ActiveSheet.Range("$C$1:$J$64").AutoFilter Field:=1, Criteria1:="1", _
Operator:=xlOr, Criteria2:="="
'Click on header, then pastes into first visible cell on the row below (the filtered row)
PasteCell.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
'Clear filters
ActiveSheet.Range("$C$1:$J$64").AutoFilter Field:=1
Range("A1").Select
End Sub
It currently fails on the first line 'Dim PasteCell As range', 424 object required.
But I am wondering if this is the best way to even go about this, ideally I would just like to look down column C until C65, and if it sees a 1, then pastes-values 3 cells to the right.
Is anyone able to come it with an elegant solution to this? My second option would be preferred as this seems the quickest way to a solution without requiring manually filtering.
Thanks
No. This doesn't look like the most suitable method. Please try the code below instead.
Sub Macro11()
' 204
Dim Arr As Variant ' temorary array
Dim Rng As Range ' temporary range
Dim Rt As Variant ' Row: target
Arr = ThisWorkbook.Worksheets("MonthlyDump").Range("N1:R1").Value
With ActiveSheet 'better to name the sheet (!)
' start lookin in row 3
Set Rng = .Range(.Cells(3, "C"), .Cells(64, "C"))
' same as above but last row is dynamic:-
' Set Rng = .Range(.Cells(3, "C"), .Cells(.Rows.Count, "C").End(xlUp))
Rt = Application.Match(1, Rng, 0)
If IsError(Rt) Then
MsgBox "No row matches the criteria.", _
vbExclamation, "Failed to post"
Else
.Cells(Rt + Rng.Row - 1, "D").Resize(1, UBound(Arr, 2)).Value = Arr
End If
End With
End Sub
This code uses the MATCH function to find the first 1 in column C. Actually, this looks like not being the optimum, either. It should be possible to look for the conditions that you use to set column C to 1 and 0, perhaps a date. If the code would look for the date, or whatever other criterium, instead of the 1 column C wouldn't be needed.
Related
I am new to VBA and have been struggling with finding a solution to copying & pasting some formulas into a range with a variable end row. I managed to cobble together the below code, which works, but it is inefficient because it pastes the formulas one row at a time. I would like to copy the formulas and then paste them into the entire range at once (instead of row by row). I have to do this function in a few different sheets and ranges so ideally I'd like to create a sub routine to find the last row. What I don't know is 1) how to find the last row 2) how to reference it when I'm selecting the range to paste the formulas into.
The sheet is setup with data in the first column, starting in cell C9, and the formulas are in D8:I8. I need to copy the formulas into the range of D9.I? (with the last row being the last row of data in column C).
I've been working on this for about 5 hours and am going out of my mind. Any help would be appreciated!
Sample of the code I have managed to write that works but isn't efficient:
Range("D8").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
ActiveCell.Offset(1, -1).Select
Do Until ActiveCell.Value = Empty
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveCell.Offset(0, -1).Select
ActiveCell.Offset(1, 0).Select
Loop
The classic way to find the last used row is shown below. Call the function like Debug.Print LastRow or, directly in the Immediate Window, with ? LastRow
Function LastRow() As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(XlUp).Row
End with
End Function
Observe that both, the .Rows.Count and the result are taken from the ActiveSheet and that the measure is taken in column "A". (You can replace the name "A" with the number 1 in the above formula). If you want to develop the function, pass both the sheet and the column to it as arguments.
.Cells(.Rows.Count, "A") defines the cell A1400000 (or thereabouts), the last cell in the column. Then the function looks for the first occupied cell above that, meaning that if A1 and A10 are in use and A2:A9 are blank, the function will return 10. It's important to understand that .Cells(.Rows.Count, "A").End(XlUp) is a range object, a cell, of which the .Row property holds the number of the row where that range is located.
Now, if you want to define a range D9:I? you might do it like this, setting the range by defining its first and last cell. Observe the 4 leading periods. Each one stands for the object in the With statement, in this case ActiveSheet.
With ActiveSheet
Set MyRange = .Range(.Cells(9, "D"), .Cells(.Rows.Count, "I").End(xlUp))
End With
But that would take the measure for the last used cell in column I. Often it's the first column on the left that is longer than the last column in the required range. In that case you might use code as shown below.
With ActiveSheet
Set MyRange = .Range(.Cells(9, "D"), .Cells(.Rows.Count, "D").End(xlUp))
End With
With MyRange
Set MyRange = .Resize(.Rows.Count, 9)
End With
The code first sets the range for column D only, presuming that column D is the longest one, and then expands it to include 9 columns. Observe the .RowsCount refers to the ActiveSheet in the first With block and to MyRange in the second.
Of course, you could achieve a similar result with this code which calls the LastRow function (which measures the last row in column A):-
With ActiveSheet
Set MyRange = .Range(.Cells(9, "D"), .Cells(LastRow, "I"))
End With
This solution is a Subroutine to fill a range with values (in this case, formulas) and find the LastRow in a separate Function. There are many ways to do this so feel free to modify it how you please.
First this Subroutine receives the relevant Worksheet, range the formulas are in and the Column letter for the start and end of our destination range.
The Sub uses the Range.AutoFill method to fill the destination range, much the same as if you click the bottom right of a cell with a value and drag up/down/left/right to fill the cells in that direction.
Public Sub AutoFillVariableSizedRangeByRow _
(ByRef TargetWorkSheet As Worksheet, _
ByVal TargetValueCellAddress As String, _
ByVal StartColumn As String, _
ByVal EndColumn As String)
Dim RangeValuesArray As Variant
Dim TargetValueCell As Range
Dim TargetRange As Range
Set TargetValueCell = TargetWorkSheet.Range(TargetValueCellAddress)
Set TargetRange = TargetWorkSheet.Range(StartColumn & Right(Mid(TargetValueCellAddress, 4), 1) & ":" & _
EndColumn & LastRow(TargetWorkSheet, "C"))
TargetValueCell.AutoFill TargetRange
End Sub
The LastRow is found by a separate function, which is well explained already in many places on the net, including another answer to this question.
Public Function LastRow(ByRef TargetSheet As Worksheet, ByVal TargetColumnLetter As String) As Long
LastRow = TargetSheet.Cells(Rows.Count, TargetColumnLetter).End(xlUp).Row
End Function
To write the LastRow function with excel references (not user defined variables), it would look like:
Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
To call the sub it could look something like:
Private Sub myProcedure()
AutoFillVariableSizedRangeByRow ThisWorkbook.Sheets("Sheet1"), "D1:I1", "D", "I"
End Sub
In the above, ThisWorkbook.Sheets("Sheet1") is TargetWorkSheet and "D1:I1" is TargetValueCellAddress, "D" and "I" are the start and end columns of our destination range respectively.
In this example, I've put values 1 to 20 down column C and the formula =$C1*$C1 in row 1 of columns D to I, all on Sheet1.
And here is the output after running AutoFillVariableSizedRangeByRow Sheet1, "D1:I1", "D", "I":
As example, the formula across row 8 is =$C8*$C8 and row 20 is =$C20*$C20.
I have a macro-enabled spreadsheet that allows me to hide various columns and rows based on certain criteria I select and trigger on the sheet.
First I select the relevant columns by marking that column with a "Y", and hiding the remaining columns with a "N" with the following routine:
Sub Hidecolumn()
Dim p As Range
For Each p In Range("H1:BN1").Cells
If p.Value = "N" Then
p.EntireColumn.Hidden = True
End If
Next p
End Sub
Please note that Columns("A:G") will always be visible. Only Columns("H:BN") can be hidden based on the above. This works perfectly.
Then, I will hide the the various rows that do not have a value in the remaining visible columns for Columns("H:BN"), which is 59 possible columns. If any column within that row has a value, then that row will remain visible. If there are NO values in any of the visible columns for that row, then I hide that row. It is entirely possible that the 59 columns could reduce to 7. I do this with the following routine:
Sub HideRowsSecond()
Module2.Unhiderow
Dim srcRng As Range, ws As Worksheet
Set ws = ActiveSheet
Set srcRng = ws.Rows("5:" & ws.Cells(ws.Rows.Count, 4).End(xlUp).Row)
Dim R As Range, hideRng As Range
For Each R In srcRng
If Application.CountA(R.Columns("H:BN").SpecialCells(xlCellTypeVisible)) = 0 Then
If hideRng Is Nothing Then
Set hideRng = R.EntireRow
Else
Set hideRng = Application.Union(hideRng, R.EntireRow)
End If
End If
Next R
If Not hideRng Is Nothing Then hideRng.EntireRow.Hidden = True
MsgBox ("Complete")
End Sub
Please note that the starting row is Row("5"), and we use Column("D") as the counting column because it has a value in every cell down to the bottom of the data set. This works perfectly.
Now that I have my desired data set, I need to save this visible data set to a new XLSX file that the user can name themselves and save in the directory of their choice. The target range will begin with cell "C3" and we need to save however many visible columns there are to the right and however many visible rows there are down to the bottom of the data set.
Can someone please help me with this final step?
Here is the solution.
Sub exportToFile()
Dim rng As Range
With ActiveSheet
Set rng = Application.Intersect(.UsedRange, .Cells.Resize(.Rows.Count - 2, .Columns.Count - 2).Offset(2, 2))
End With
rng.Select
rng.SpecialCells(xlCellTypeVisible).copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("A" & Row & ":N" & Row).EntireRow.AutoFit
ActiveSheet.Range("A1").Select
Application.Dialogs(xlDialogSaveAs).Show ("c:\")
End Sub
We are looking to automate this process using Excel VBA/macros because we process two to ten spreadsheets a week.
We want to extract a certain number of rows per a variable set of phone numbers.
For example: a spreadsheet with 200,000 rows has 20,000 rows assigned to ten phone numbers. We want to extract the first ten rows per phone number. Our resulting file will have 100 rows ordered by phone number.
Notes:
We need to extract a variable number of records per phone number.
The number of columns can vary.
The number of rows can vary.
We need the entire row of data.
The phone number column may be in a different place in each spreadsheet.
The number of phone numbers may vary.
Here's a code that works on one file, but cannot be duplicated to another worksheet because the "field", "criteria" and "rows" change per worksheet.
We thought IndexMatch might work, but it only returns one item, rather than duplicates.
We don't have a VBA solution, so we do this manually.
Any help would be appreciated!
Sub ExtractPh()
' Establish filter
' Choose first unique phone number
Cells.Select
Selection.AutoFilter
ActiveSheet.UsedRange.AutoFilter Field:=25, Criteria1:= _
"800-836-9207"
' Copy ten non-sequential rows from row 1 to row 82
Rows("1:82").Select
Selection.Copy
' Add rows to second sheet
Sheets.Add After:=Sheets(Sheets.Count)
Rows("1:1").Select
ActiveSheet.Paste
' Move second to sheet to first position to save as separate file
Sheets("Sheet1").Select
Application.CutCopyMode = False
Sheets("Sheet1").Move Before:=Sheets(1)
' Return to main data sheet
Sheets("Test LKY job").Select
' Choose second unique phone number in column
ActiveSheet.UsedRange.AutoFilter Field:=25, Criteria1:= _
"800-907-3803"
' Choose second set of ten non-sequential rows and paste to first sheet
Rows("6:26").Select
Selection.Copy
Sheets("Sheet1").Select
Rows("12:12").Select
ActiveSheet.Paste
' Return to main data sheet
Sheets("Test LKY job").Select
' Choose third unique phone number in column
ActiveSheet.UsedRange.AutoFilter Field:=25, Criteria1:= _
"800-538-1668"
' Choose third set of non-sequential rows and paste to first sheet
Rows("4:48").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Rows("22:22").Select
ActiveSheet.Paste
End Sub
Here's some sample code showing how you can filter a sheet, grab a specific number of visible rows, then copy those rows to another sheet.
Sub Tester()
Dim rng As Range, rngDest As Range
Set rngDest = Sheet2.Range("A2")
Set rng = GetFirstVisibleRows(ActiveSheet, 1, "A", 10)
If Not rng Is Nothing Then
rng.EntireRow.Copy rngDest
Set rngDest = rngDest.Offset(rng.Cells.Count, 0)
End If
End Sub
'filter the data on a sheet by a given value in a given column, then
' return a range with the first x visible rows
Function GetFirstVisibleRows(sht As Worksheet, filterColumn As Long, _
filterValue, howManyRows As Long) As Range
Dim c As Range, rngVis As Range, rngCopy As Range
'filter the sheet and find the remaining visible rows (if any)
With sht.UsedRange
.AutoFilter
.AutoFilter Field:=filterColumn, Criteria1:=filterValue
On Error Resume Next '<< ignore error if no visible cells
'offset/resize is to ignore the header row...
Set rngVis = .Columns(1).Offset(1, 0).Resize(.Columns(1).Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0 '<< stop ignoring errors
End With
If Not rngVis Is Nothing Then
'some visible (not filtered out) rows, so collect the first x of those...
For Each c In rngVis.Cells
If rngCopy Is Nothing Then
Set rngCopy = c
Else
Set rngCopy = Application.Union(c, rngCopy)
End If
'exit loop if we have enough rows
If rngCopy.Cells.Count >= howManyRows Then Exit For
Next c
End If
Set GetFirstVisibleRows = rngCopy
End Function
I am currently trying to write a macro that essentially takes a column,duplicates it to the right, then changes certain references to refer back to the previous column.
I am using the replace method, but because i am looking for a specific string based on the column letter and "2" I used an object to bring together the column letter and the "2".A better way to explain is say I copied column B and inserted it and made a duplicate in column C.
I now want to find "C2 and "C3" in my formulas and change them to "B2" and "B3".
I figured this would be done by finding the aforementioned strings by using the replace method and offsetting them by -1. This has proved rather difficult. Any ideas?
'duplicates column over 1'
ActiveCell.EntireColumn.Select
Selection.Copy
ActiveCell.Offset(0, 1).EntireColumn.Select
Selection.Insert Shift:=xlToRight
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone
Application.CutCopyMode = False
'Declarations and Instantiations'
Dim rngo As Range, cell As Range, ranger As Range
Dim lookfor As String
Dim UsedRng As Range, LastRow As Long
Set rngo = Selection.EntireColumn
Set UsedRng = ActiveSheet.UsedRange
LastRow = UsedRng(UsedRng.Cells.Count).Row
rngo.Select
Do Until ActiveCell.Row = LastRow + 1
For Each cell In rngo
Col = SPLIT(ActiveCell(1).Address(1, 0), "$")(0) 'returns just the cell letter'
lookfor = (Col & "2") 'combines the column letter with the number(I BELIEVE THIS IS THE SOURCE OF THE ISSUE BUT IM NOT SURE IN WHAT WAY'
'starts to search the new column for "lookfor" which is just the designated string'
rngo.Replace _What:=lookfor, Replacement:="'offset lookfor by 1 column'",_SearchOrder:=xlByRows, MatchCase:=True
Next cell
ActiveCell.Offset(1, 0).Select
Loop
MsgBox ColumnName(Selection)
MsgBox lookfor
End Sub
Solved: change " rngo.Replace" to "ActiveCell.Replace"
I have a table put together as a database. I am trying to write a macro to search a System Size column in my table to find "2500" then search a Standard column to find "Standard" then search a Category column to find "FL" I then want to copy the value from a Select Item column pertaining to the row these values were found in to another sheet. For example, the macro will search Column E (System Size) for all "2500", then it will search Column F (Standard) for all "Standard", then it will search Column G (Category) for all "FL". I then want it to copy the values from Column C (Select Item) for every line that meets these requirements and paste it to another sheet. Following is the code I have so far but I can only get it to search one cell and not the entire column. There is probably a better way to go about it but this is the only way I have found that works.
Sub ImDoingMyBest()
'
' ImDoingMyBest Macro
'
'
If Sheets("Database").Range("E2").Value Like "*2500*" Then
Sheets("Database").Range("C2").Copy
Sheets("Quote Sheet").Select
Range("B26").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End If
End Sub
The way to search the whole column is to use a for-loop; for instance:
For i = 1 To 10000
If Sheets("Database").Range("E" & i).Value Like "*2500*" Then
Sheets("Database").Range("C" & i).Copy
...
...
End If
Next i
Alternatively (and my preference) use the Cells(row, column) format rather than Range - this avoids having to concatenate the Range reference. This would take
Range("E" & i)
and change to
Cells(i, 5)
which is neater code (IMO).
Following up on Siddarth Rout's comments, the following code uses Autofilter to isolate the rows in the "Database" sheet that meet your criteria, and then copies the corresponding values in column C to a range beginning in cell B26 of the sheet named "Quote Sheet".
Sub FilterAndCopy()
Dim dataWs As Worksheet
Dim copyWs As Worksheet
Dim totRows As Long
Dim lastRow As Long
Set dataWs = Worksheets("Database")
Set copyWs = Worksheets("Quote Sheet")
With dataWs
.AutoFilterMode = False
With .Range("C:G")
.AutoFilter Field:=3, Criteria1:="2500"
.AutoFilter Field:=4, Criteria1:="Standard"
.AutoFilter Field:=5, Criteria1:="FL"
End With
End With
totRows = dataWs.Range("C:C").Rows.count
lastRow = dataWs.Range("C" & totRows).End(xlUp).Row
dataWs.Range("C2:C" & lastRow).Copy
copyWs.Range("B26").PasteSpecial Paste:=xlPasteValues
dataWs.AutoFilterMode = False
End Sub