Working on Microsoft Visual Basic Application Edition 7.1 in Excel 2013
Data are on columns from A to D, rows' number varies from time to time. I would like to delete all rows for which column B's value doesn't start with LCR (and also I would like not to bore with a for...next loop).
Something like:
Columns("B:B").AutoFilter Field:=1, Criteria1:="<>LCR*"
Selection.Delete
Unfortunately, this code deletes heading row (row number 1) and I don't want.
I tried to store row number 1 elsewhere in a range variable, but it doesn't work (run-time error '424')
Set r1 = Range("A1:D1")
r1.Copy
Columns("B:B").AutoFilter Field:=1, Criteria1:="<>LCR*"
Selection.Delete
With Range("A1:D1")
.Insert Shift:=xlDown
.Select
.Value = r1.Value
End With
How can I tell the filter to start from row number two (or how can I correctly store content of row number one so to paste it after deletion by filter)?
Thanks in advance for your help
Define your range for deleting as Range(Cells(2,2),Cells(ActiveSheet.UsedRange.Rows.Count,2)) (To replace the Selection call). This will delete everything except for the first cell in the column
Edit to avoid excel prompt: Range(Cells(2,2),Cells(ActiveSheet.UsedRange.Rows.Count,2)).EntireRow
in a more complete way you could go like this
Sub main()
With Worksheets("MyWantedSheet") '<--| always specify full worksheet reference (change "MyWantedSheet" with your actual sheet name)
With .Columns("B:B") '.Resize(.Cells(.Rows.Count, "B").End(xlUp).Row) '<--| refer to wanted column range down to its last non empty cell
.AutoFilter '<--| remove possible preeeding autofilter filtering
.AutoFilter Field:=1, Criteria1:="<>LCR*" '<--| apply current filtering
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then '<--| if there are visible cells other than the "header" one
.Resize(.Parent.Cells(.Parent.Rows.Count, "B").End(xlUp).Row - 1).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete '<--|delete visible rows other than the first ("headers") one
End If
End With
.AutoFilterMode = False '<--| remove drop-down arrows
End With
End Sub
Related
I need VBA code for the following:
If cells in a certain column contain a certain word, I need to cut and paste the entire row onto a different sheet. I found some code, but it matches the row on the destination sheet. I just need it to go on to the different sheet and be deleted from the source.
Can anyone kindly advise?
if your "Column" has a header as its first cell then you can use AutoFilter() as per following code (see comments to adjust it to your actual needs)
Sub main()
With Worksheets("mySheetName") '<--| reference the worksheet with data (change "mySheetName" to your actual worksheet with data name
With .Range("A1", .Cells(.Rows.count, "A").End(xlUp)) '<--| reference its "column" (change "A" occurrences to your actual column with data index)
.AutoFilter Field:=1, Criteria1:="d" '<--| change "word" to your actual word to be looked for
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then
With .Resize(.Rows.count - 1).Offset(1).SpecialCells(xlCellTypeVisible)
.Copy Worksheets("myOtherSheetName").Range("A1")
Application.DisplayAlerts = False
.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
End With
End If
.AutoFilterMode = False
End With
End With
End Sub
New to VBA, and I'm trying to create multiple ranges or arrays based on a criteria in a column, then place those in a separate worksheet. The issue is that this code has to work for several different data sets. So one data sat will look something like
this, but with far more data points ( around 10,000 for each data set).
So what I'm trying to do is, for each group of 1's in the state column, create a range/array, then move the corresponding time and data in a new worksheet. So for the example I have, there would be 3 new worksheets, with the first new worksheet containing range("A2:B5"), the second one containing range("A10:B12"). With each data set, the state column changes and the number of new worksheets can also vary.
I have looked through this site, and the closest I have found to my needs is Creating Dynamic Range based on cell value, but it has a known number of ranges. I quite honestly have no idea how to accomplish what I need. I've been trying to make a while loop inside of a if then loop inside of a for each loop, but can't make it work.
Any help would be greatly appreciated! Been banging my head for hours now.
this should help you:
Option Explicit
Sub main()
Dim area As Range
With Sheets("myDataSheet") '<--| reference your sheet (change "myDataSheet") to your actual sheet name
With .Range("C1", .Cells(.Rows.Count, "A").End(xlUp)) '<--| reference its columns A:C range form row 1 down to last column A not empty row
.AutoFilter Field:=3, Criteria1:="1" '<--| filter referenced range on its 3rd column (i.e. "State") with 1
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filterd cells other than header
For Each area In .Resize(.Rows.Count - 1, 2).Offset(1).SpecialCells(xlCellTypeVisible).Areas '<--| loop through filtered range (skipping header) 'Areas'
area.Copy Sheets.Add(Sheets(Sheets.Count)).Range("A1") '<--| copy current 'Area' into new sheet
Next area
End If
End With
.AutoFilterMode = False
End With
End Sub
So I have a large data set where I would like to combine rows depending if the information in the first column matches to a certain degree. I was wondering if there is a macro that could do this. Below I have included images of a similar simplified data set. I would assume the macro would create the new table in a new worksheet or insert a row below the existing data but I am not sure. Any help or tips on this problem would be very helpful.
Sample dataset:
Output:
you may try the following (commented) code:
Option Explicit
Sub main()
Dim cell As Range, cell2 As Range
With Worksheets("experiment").Range("A1").CurrentRegion '<--| reference data worksheet(change "experiment" to its actual name) cell "A1" contiguous range column "A"
.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes '<--| sort it by "experiment" column to have "smaller" names at the top
For Each cell In .Offset(1).Resize(.Rows.Count - 1, 1) '<--| loop through its 1st column cells skipping header row
If cell.Value <> "" Then '<--| if current cell isn't blank (also as a result of subsequent operations)
.AutoFilter Field:=1, Criteria1:="*" & cell.Value & "*" '<--| filter on referenced column to get cell "containing" current cell content
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 2 Then '<--| if more than 2 rows has been foun: header row gets always filtered so to have at least 2 rows to consolidate we must filter at least 3
With .Offset(1).Resize(.Rows.Count - 1) '<--| reference filtered rows skipping header row
For Each cell2 In .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible).Areas(1).Rows(1).Cells '<--| loop through 1st filtered row cells skipping 1st column ("experiment")
cell2.Value = WorksheetFunction.Subtotal(9, cell2.EntireColumn) '<--| update their content to the sum of filtered cells in corresponding column
Next cell2
With .Resize(, 1).SpecialCells(xlCellTypeVisible) '<--| reference filtered rows 1st column ("experiment") cells
.Value = .Cells(1, 1) '<--| have them share the same name
End With
.RemoveDuplicates Columns:=Array(1), Header:=xlNo '<--| remove duplicates, thus leaving the 1st filtered row with totals
End With
End If
End If
Next cell
.Parent.AutoFilterMode = False '<--| show all rows back
End With
End Sub
Add a column that extracts the first few characters of the first column. Then create a pivot table with that new column in the rows and the other columns in the values area. No VBA required.
I've been banging my head on this one for a while.
I have a big macro I made doing a number of operations on a file but got stuck on doing a series of filtering and vlookups.
Here is a portion of what I got. I added comments to make it clearer.
'FILTER ALL 3P VALUES IN ONE COLUMN AND ADD A VALUE IN ALL RESPECTIVE CELLS IN OTHER COLUMN
Application.ScreenUpdating = False
With ActiveSheet.UsedRange
.AutoFilter Field:=22, Criteria1:="*3P*"
.Offset(1).Range("AU1:AU" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select
'HERE I SELECT ALL VISIBLE FILTERED CELLS BY COUNTING IN ROW A BECAUSE THESE CELLS ARENT BLANK
.Selection.Value = "3P PROGRAM"
.AutoFilter
End With
'NOW I WANT TO FILTER ROW FOR BLANKS AND THEN FILL THIS RANGE WITH A FORMULA
'HERE IS THE PROBLEM
With ActiveSheet.UsedRange
.AutoFilter Field:=47, Criteria1:="="
.Offset(1).Range("AU1:AU" & Cells(Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Select
.Selection.FormulaR1C1 = "=VLOOKUP(RC[-38],'[WeeklyData.xlsx]Sheet1'!C8:C16,9,FALSE)"
.AutoFilter
End With
Problem is at the vlookup step. I want that range of visible filtered blank cells to get the value gotten by vlookup. Every cell should take a cell 38 columns to the left as a vlookup reference.
I cant find a way to make formula work. I would like to:
-insert vlookup to that filtered range,
-remove filter (Autofilter)
-Select calculated column with offset of 1 for headers and paste as special values
- carry on to do this process 5, 6 more times for blank or invalid entries in other columns.
Is there a way to do this?
Any help is appreciated
I prefer the Range.CurrentRegion property over the Worksheet.UsedRange property. It refers to the 'data island' created at the origin point (in this case, A1).
With ActiveSheet
If .AutoFilterMode Then AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
'Set the filter
.AutoFilter Field:=22, Criteria1:="*3P*"
'Shift off the header row
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
'check if there are any visible cells
If CBool(Application.Subtotal(103, .Cells)) Then
'Put 3P PROGRAM into the visible cells in column AU
Intersect(.Columns(47), .SpecialCells(xlCellTypeVisible)) = "3P PROGRAM"
End If
End With
'remove the filter
.AutoFilter Field:=22
'set the formula on column AU blank cells
Intersect(.Columns(47), .SpecialCells(xlCellTypeBlanks)).FormulaR1C1 = _
"=VLOOKUP(RC[-38], '[WeeklyData.xlsx]Sheet1'!C8:C16, 9, FALSE)"
'revert column AU within the .CurrentRegion to the values returned by the formulas
.columns(47).cells = .columns(47).cells.value
End With
End With
The second filter is replaced by using the Range.SpecialCells method with the xlCellTypeBlanks property. The Intersect method isolates the cell range reference to the blank cells within column AU. You may want to make a check for blank cells before running that operation.
I'm trying to make a code that checks for numbers in a master sheet called All in column D (ex. 780101) and if it meets the criteria, it copies the whole row and inserts (not paste) it to another sheet with the name of the criteria (ex. 780101), starting on row 6.
The code I have doesn't work like I want it to. It doesn't copy all the rows that meet the criteria and sometimes it inserts blank rows.
Sub Insert()
For Each Cell In Sheets("All").Range("D:D")
If Cell.Value = "780101" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow + 1).Select
Selection.Copy
Sheets("780101").Select
Rows("6:6").Select
Selection.Insert Shift:=xlDown
End If
Next
End Sub
I'm just starting to learn VBA, so if it could be possible the names of the sheets would be the criteria of the cell values (the code is made for only one sheet - 780101, but there are 20 of sheets with different names).
It's tough to make recommendations without seeing sample data and what could potentially be causing the problems you are having but you can run this rehash of your existing code.
Sub Insert()
Dim dc As Range
With Sheets("All")
For Each dc In Intersect(.Range("D:D"), .UsedRange)
If dc.Value2 = 780101 Then
dc.Resize(2, 1).EntireRow.Copy
Sheets("780101").Rows(6).Insert Shift:=xlDown
End If
Next
End With
End Sub
The nature of running that from top to bottom means that the results will be reversed. You may wish to consider running the main loop from bottom to top to maintain the order.