Apologies editing .I have this below code which copies data of one row from 1 sheet to another (there are blanks in between). The code works fine, however I would like it copy only visible fields from sheet 1 (filters already applied).
This is copying the entire column U irrespective of the filters applied (filters are applied I column 10 and 38)
With Worksheets("Sheet1")
Set SrcRng = .Range(.Cells(1, "U"), .Cells(.Rows.Count, "U").End(xlUp))
End With
Worksheets("Sheet2").range("I1").Resize(SrcRng.Rows.Count, 1).Value = SrcRng.Value'
Please help
Try:
Sub CopyVisible()
Dim ws As Worksheet, ws2 As Worksheet
Dim SrcRange As Range, CpyRng As Range
Dim LRow As Long
Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
If ws.AutoFilterMode Then ws.AutoFilter.ShowAllData 'Removes Previous Filters
With ws
LRow = .Cells(.Rows.Count, 8).End(xlUp).Row 'Check Col "H" for last data
Set SrcRng = .Range(.Cells(1, 1), .Cells(LRow, 39)) 'Range with Data
With SrcRng
.AutoFilter Field:=39, Criteria1:="Blue"
.AutoFilter Field:=8, Criteria1:="Pass"
.AutoFilter Field:=10, Criteria1:="<>"
End With
For i = 1 To LRow 'Loop through all Rows
If Not .Cells(i, 1).EntireRow.Hidden Then 'Checks if Row is Hidden
If CpyRng Is Nothing Then
Set CpyRng = .Range("U" & i)
Else
Set CpyRng = Union(CpyRng, .Range("U" & i))
End If
End If
Next i
End With
ws.AutoFilter.ShowAllData 'Remove Filters
CpyRng.Copy ws2.Range("I1") 'Copy and Paste
End Sub
Will apply filters to all Columns from 1 to 39 and filter with the wanted criteria. Creates range with all visible rows in Col U and paste them into Sheet2 into Col I.
Related
As you see on the above picture, I need to use AutoFilter to show rows contains specific value e.g 102.
With Excel interface , I cannot use the criteria value 102 on Columns “B” & “C” on the same time.
I want to maintain the sort and structure of my dataset.
As a workaround, is it possible to show rows contains value 102 on Columns “B” & “C” and hide the other rows in between.
In advance I am grateful for all your help.
Sub Filter_criteria()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim rng As Range
Set rng = ws.Range("A2:R" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
If Not ws.AutoFilterMode Then rng.AutoFilter 'Set AutoFilter if not already set
rng.AutoFilter Field:=2, Criteria1:="*102*", Operator:=xlAnd
End Sub
Please, test the next adapted code. It firstly, apply a filter on the second column, then unhide rows if the third column contains criteria:
Sub Filter_criteria()
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Const crit As String = "*102*"
If ws.AutoFilterMode Then ws.AutoFilterMode = False
Dim rng As Range: Set rng = ws.Range("A1:R" & ws.cells(rows.count, "A").End(xlUp).row)
'place the first filter in second column:
rng.AutoFilter field:=2, Criteria1:=crit, Operator:=xlFilterValues
'unhide according to the third column, by iteration:
For i = 1 To rng.rows.count
If rng.cells(i, 3).Value Like crit Then rng.rows(i).Hidden = False
Next i
End Sub
A second version follows somehow BibBen's suggestion. The code builds an array as result of B:B and C:C concatenation and drop its content after the last column (after R:R), then filter by it and clear at the end:
Sub evaluateConcat()
Dim ws As Worksheet, lastR As Long, lastCol As Long, rng As Range, arr
Const crit As String = "*102*"
Set ws = ActiveSheet
If ws.AutoFilterMode Then ws.AutoFilterMode = False
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
lastCol = ws.cells(1, ws.Columns.count).End(xlToLeft).Column
Set rng = ws.Range("A1:S" & lastR)
'create an array as concatenation between columns B:B and C:C
arr = Evaluate(ws.Range("B2:B" & lastR).Address & "&" & ws.Range("C2:C" & lastR).Address)
With ws.cells(1, lastCol + 1)
.Value = "ConcCol" 'header
.Offset(1).Resize(UBound(arr), 1).Value = arr 'drop the array content after the last column
End With
rng.AutoFilter field:=lastCol + 1, Criteria1:=crit, Operator:=xlFilterValues 'filter by the above built column
ws.Columns(lastCol + 1).ClearContents 'clear the content of the added column
End Sub
Edited:
A third version will iterate between the two columns keeping criteria, placed in an array and build a Union range (of not matching criteria) to be finally hidden:
Sub FilterByTwoCols()
Dim ws As Worksheet, lastR As Long, arr, i As Long, HdRng As Range
Const crit As String = "*102*"
Set ws = ThisWorkbook.ActiveSheet
ws.UsedRange.EntireRow.Hidden = False 'make all rows visible
lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
arr = ws.Range("B2:C" & lastR).Value2 'place the relevant columns in an array for faster iteration
For i = 1 To UBound(arr)
If Not arr(i, 1) & arr(i, 2) Like crit Then
addToRange HdRng, ws.Range("A" & i + 1) 'make a Union range of the rows NOT matching criteria...
End If
Next i
If Not HdRng Is Nothing Then HdRng.EntireRow.Hidden = True 'hide not matching criteria rows.
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
I have 5 columns of data. The data is grouped by employee name and number (cols A-B) and their respective pay types (col C). I need to
Copy employee name to blank cell below in col A
Copy employee number to blank cell below in col B
Add the word "Advance" in the blank cell in col C
Current code selects all blank cells in cols A-E and fills with the values from above:
Sub FillBlanksValueAbove1()
Dim sName As String
sName = ActiveSheet.Name
Dim ws As Worksheet
Dim lastRow As Long, lastCol As Long
Dim rng As Range
'Set variable ws Active Sheet name
Set ws = Sheets(sName)
With ws
'Get the last row and last column
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
'Set the range
Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
rng.Select
'Select Blanks
rng.SpecialCells(xlCellTypeBlanks).Select
'Fill Blanks with value above
Selection.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rng.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub
This is what the spreadsheet looks like now:
This is what I need it to look like:
This is the end result I currently get:
Thank you so so much!
Test the next code, please. No need of any selection, a little simplified:
Sub FillBlanksValueAbove1()
Dim rng As Range, rngVis As Range
Dim ws As Worksheet, lastRow As Long
'Set variable ws Active Sheet name
Set ws = ActiveSheet
With ws
'Get the last row
lastRow = .Range("A" & .Rows.count).End(xlUp).Row
'Set the range
Set rng = .Range(.cells(1, 1), .cells(lastRow, 2)) 'Col B:C
Set rngVis = rng.SpecialCells(xlCellTypeBlanks)
'Fill ADVANCE in column C:C
rngVis.Offset(, 1).Value = "ADVANCE"
'Fill Blanks with value above
rngVis.FormulaR1C1 = "=R[-1]C"
'Paste Formulas as Values
rngVis.Value = rngVis.Value
End With
End Sub
I'm using code below to copy rows from Sheet1 to Sheet2.
I have 3 questions about.
Why this function always copy row A2? Even if value is "0".
How to copy just value, no formatting?
Is it possible to skip column B when copy? "C" from Sheet1 will be "B" in Sheet2, etc.
Sub COPY_SA()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheets to suit
Set ws1 = ThisWorkbook.Worksheets("SA")
Set ws2 = ThisWorkbook.Worksheets("JC_input")
With ws1
'assumung that your data stored in column A:D, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:D" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=4, Criteria1:=">0"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.CopyDestination:=ws2.Range("A2")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False End Sub
I manage to modify like below. Still have issue with range in Worksheet "ws1". Cannot set filter in second row and copy range from row 3. That is why added: "ws2.Rows(3).Delete". Code always copy row 1.
Row 1 got some comments.
Row 2 got column names.
Sub COPY_SA()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheets to suit
Set ws1 = ThisWorkbook.Worksheets("SA")
Set ws2 = ThisWorkbook.Worksheets("JC_input")
With ws1
'assumung that data stored in column C:E, Sheet1
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
'can not make range from row 3 ???
Set rng = .Range("C1:E" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter with criteria in column 3 of range C:E
'can not make filter in row 2 ???
.AutoFilter Field:=3, Criteria1:=">0"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Range("A:C").Copy
'paste from row 3
ws2.Range("A3").PasteSpecial Paste:=xlValues
'delete no needed row
ws2.Rows(3).Delete
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
If Not ActiveSheet.AutoFilterMode Then
ws1.Range("2:2").AutoFilter
End If
End Sub
Try this quick fix, assuming your headers on both sheets are in the first row:
Sub COPY_SA()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheets to suit
Set ws1 = ThisWorkbook.Worksheets("SA")
Set ws2 = ThisWorkbook.Worksheets("JC_input")
With ws1
'assumung that your data stored in column A:D, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:D" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=4, Criteria1:=">0"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Range("A:A,C:D").Copy
ws2.Range("A1").PasteSpecial Paste:=xlValues
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
To answer your questions:
Why this function always copy row A2? Even if value is "0".
That's because you have set a range starting from the second row and applied a filter to it.
We can change that in the code through setting the range from A1:D & Lastrow and also paste it to ws2.Range("A1").
How to copy just value, no formatting?
Yes it's possible, but you'll need to copy and paste as xlValues as explained by #Peh here
The change in code therefore is to .Copy a range and in the next line .PasteSpecial the xlValues.
Is it possible to skip column B when copy? "C" from Sheet1 will be "B" in Sheet2, etc.
Yes instead of copying the whole range, we can specify which columns you would want to copy, this can be a non-contiguous range of columns.
We can change the .Copy part to include only these specific columns we need.
I'm sure the whole thing can be written neater but this should at least do what you are after.
I've tried multiple codes without luck. I have an excel sheet with 1800 rows and the following columns: ProgramCode, StudyBoard, FacultyID and ProgramType.
In the StudyBoard column there are some cells that are empty. I will then find all the empty cells in StudyBoard and their corresponding information from the other columns. Once I've found the desired cells, they must be overwritten in a new sheet.
I have the following codes, and couldn't continue, because even what I try isn't working.
Dim ws As Worksheet
Dim StudyBoardCol As Range
Dim PromgramCodeCol As Range
Dim rndCell As Range
Dim foundId As Variant
Dim msg As String
Dim FacultyIdCol As Range
Dim ProgramTypeLetter As Range
Set ws = ThisWorkbook.Worksheets("SSBB")
Set StudyBoardCol = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
Set ProgramCodeCol = ws.Range("B2:B" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row)
Set FacultyIdCol = ws.Range("C2:C" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
Set ProgramTypeLetter = ws.Range("D2:D" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Row)
For i = 2 To 1800
Set rndCell = StudyBoardCol.Cells(Int(Rnd * StudyBoardCol.Cells.Count) + 1)
FacultyIdCol = Application.Match(rndCell.Value, ProgramCodeCol, 0)
ProgramTypeLetter = Application.Match(rndCell.Value, ProgramCodeCol, 0)
You could use SpecialCells to “isolate” blank ones
Dim cell As Range
Dim newSheet As Worksheet
Set newSheet = Sheets.Add
With ThisWorkbook.WorkSheets("SSBB") ‘reference “SSBB” sheet
For Each cell in .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeBlanks) ‘ loop through referenced sheet column A blank cells from row 2 down to last not empty one
cell.Resize(,3).Copy destination:=newSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1) ‘ copy range next to current cell and paste to newSheet column A first empty cell
Next
End With
Or use Autofilter (you probably want to add a test that cells are present to be copied before attempting to set rng
Option Explicit
Public Sub TransferBlankStudyBoard()
Dim rng As Range
With ThisWorkbook.Worksheets("SSBB").UsedRange 'Or limit to columns A:D
.AutoFilter
.AutoFilter Field:=1, Criteria1:="="
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).EntireRow.Delete
.AutoFilter
End With
End Sub
I'm new to VBA and after much searching, i can't get the code working correctly. I am trying to filter/select anything which has the value 313 in column B AND the values 1 OR 2 in column C then copy all the relevant rows with the data from all columns (A-N) at the bottom of the same worksheet. The worksheet does not have a set number of rows and 313 is not always in the same set of cells. I have tried the following but the code seems to be pasting in 'A2' rather than the selection at the bottom. Any help would be much appreciated.
Sub CopyPartOfFilteredRange()
Dim ws1 As Worksheet
Dim filterRange As range
Dim copyRange As range
Dim lastRow As Long
Set ws1 = ThisWorkbook.Sheets("Sheet 1")
ws1.AutoFilterMode = False
lastRow = ws1.range("A" & ws1.Rows.Count).End(xlUp).Row
Set filterRange = ws1.range("A1:N" & lastRow)
Set copyRange = ws1.range("A2:N" & lastRow)
filterRange.AutoFilter Field:=2, Criteria1:="313"
filterRange.AutoFilter Field:=3, Criteria1:="=1", _
Operator:=xlAnd, Criteria2:="=2"
lastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ws1.Cells(lastRow, 1).Select
ws1.Paste
ws1.AutoFilterMode = False
End Sub
you must:
change xlAnd into xlOr
increase lastRow of 1 to reference the cell to paste in
use SpecialCells(xlCellTypeVisible) to select filtered cells (if any!)
try his
Option Explicit
Sub CopyPartOfFilteredRange()
Dim lastRow As Long
With ThisWorkbook.Sheets("Sheet 1")
.AutoFilterMode = False
lastRow = .Range("A" & .Rows.Count).End(xlUp).row
With .Range("A1:N" & lastRow)
.AutoFilter Field:=2, Criteria1:="313"
.AutoFilter Field:=3, Criteria1:="1", Operator:=xlOr, Criteria2:="2"
If Application.WorksheetFunction.Subtotal(103, .Cells.Resize(, 1)) > 1 Then 'count visible cells in column "A" other than the header
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy .Cells(lastRow + 1, 1)
End If
End With
.AutoFilterMode = False
End With
End Sub
I believe that because you are redefining the last row after a filter, using xlUp will miss the last row since it may be hidden in the filter. I would suggest using
lastRow = lastRow + 1
since you already have the last row of the range defined and you just want to past one row below that.
Your second filter, by the way, will filter on nothing because no cell will be both equal to 1 and equal to 2. Not sure what you want there. In any case, like I said in my comment, I don't believe you are copying anything, so you will need
filterRange.Copy
after the filter. I am not sure I would recommend copying and pasting like this, but I am going to try to just modify your code instead of rewriting it.
Also, I don't believe that
Set copyRange = ws1.range("A2:N" & lastRow)
is needed at all and can be deleted.
This is what I have in full
Sub CopyPartOfFilteredRange()
Dim ws1 As Worksheet
Dim filterRange As Range
Dim lastRow As Long
Set ws1 = Worksheets("Sheet1")
ws1.AutoFilterMode = False
lastRow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
Set filterRange = ws1.Range("A1:N" & lastRow)
filterRange.AutoFilter Field:=2, Criteria1:="313"
filterRange.Copy
lastRow = lastRow + 1
ws1.Cells(lastRow, 1).Select
ws1.Paste
ws1.AutoFilterMode = False
End Sub