I'm sure this has already been answered elsewhere but I just can't find it (or get what I've found to work for me).
Col "A" is a list of items with many duplicates.
In Col "B" I've placed an "X" for the items in Col "A" that I'm interested in.
What I'd like to get out of this on a separate sheet is a list of unique values for only the items on the list where there's an "X" in Col "B".
Values only would be a plus.
If your sheet has headers, the below might work for you.
If your sheet doesn't have headers, you could modify the code so that it inserts a row first.
Option Explicit
Private Sub FilterAndPasteUniques()
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called
Dim lastSourceRow As Long
lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row
Dim toFilterIncludingHeaders As Range
Set toFilterIncludingHeaders = sourceSheet.Range("A1", "B" & lastSourceRow)
toFilterIncludingHeaders.AutoFilter Field:=2, Criteria1:="X"
Dim cellsToCopy As Range
On Error Resume Next
Set cellsToCopy = toFilterIncludingHeaders.Offset(1).Resize(toFilterIncludingHeaders.Rows.CountLarge - 1, 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not (cellsToCopy Is Nothing) Then
cellsToCopy.Copy
Dim destinationSheet As Worksheet
Set destinationSheet = ThisWorkbook.Worksheets("Sheet2") ' Change to whatever yours is called
With destinationSheet.Range("A1")
.PasteSpecial xlPasteValuesAndNumberFormats
.Resize(cellsToCopy.Rows.CountLarge, cellsToCopy.Columns.CountLarge).RemoveDuplicates Columns:=1, Header:=xlNo
End With
End If
sourceSheet.AutoFilterMode = False
Application.CutCopyMode = False
End Sub
Related
I am new to VBA...trying to search specific columns by name and paste them into a new sheet.
What I have so far seems clunky and does not copy or paste the desired column but what I currently have on my clipboard!
Ideally I would be able to search 3 different columns and paste them on to the new sheet.
Any help would be greatly appreciated
Dim CheckText As String
Dim CheckRow As Long
Dim FindText As Range
Dim CopyColumn As String
CheckText = “Bsp” 'Bsp is an example header
CheckRow = 1 'Row with desired header
Dim oldsheet As Worksheet
Set oldsheet = ActiveSheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Pivot"
oldsheet.Activate
ActiveSheet.Select
'trying here to create a new sheet, name it and go back to the first sheet
Set FindText = Rows(CheckRow).Find(CheckText)
If FindText Is Nothing Then
MsgBox "Bsp not found"
End If
CopyColumn = Cells(CheckRow, FindText.Column).Column
Columns(CopyColumn).Select.Copy
Sheets("Pivot").Select
ActiveSheet.Paste
This is just a generic example that you can adjust to fit your needs. The code will look for column header named Some String. IF this column is found, we next determine the last row, copy the column (down to last row), and then paste the column in cell A1 on Pivot sheet.
Use the range variable Found to store your column header properties (namely location)
Check if the header is actually found! If Not Found is Nothing (Translation: Found)
Use Found.Column to reference the column index which fits into the Cells property nicely since the syntax is Cells(Row Index, Column Index)
Option Explicit
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<== Sheet that has raw data
Dim LRow As Long, Found As Range
Set Found = ws.Range("A1:Z1").Find("Some String") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If
End Sub
You are going to want to amend some of the options on the Range.Find method. Details can be found here
I ended up using this code in an attempted to search for another header and copy and paste it
Option Explicit
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Pivot"
ws.Activate
ActiveSheet.Select
Dim LRow As Long, Found As Range
Set Found = ws.Range("A1:EM1").Find("Bsp") '<== Header name to search for
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("A1").PasteSpecial xlPasteValues '<== Sheet to paste data
End If
ws.Activate
ActiveSheet.Select
Set Found = ws.Range("A1:EM1").Find("Sog")
If Not Found Is Nothing Then
LRow = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
ws.Range(ws.Cells(1, Found.Column), ws.Cells(LRow, Found.Column)).Copy
Sheets("Pivot").Range("B1").PasteSpecial xlPasteValues
End If
End Sub
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
I have a table Named "Combined" which is stored on one sheet of a work book.
On a second sheet I have the following Cell Range (in C1:F2)
Delivery | Column Ref | Column Ref | Available
Delivery ID | I | J | YES
I want to be able to use VBA to filter the table based on the values in this cell range
The Data drop column is a cell with a drop down list which uses VLOOKUP to populate the two column ref cells. These are the two columns that need to be filtered.
Column I needs to show all rows that <>"X" while column J needs to show all rows that equal the value in the available column.
I then need to be able to copy columns A,G and the column that appears in the first reference cell to cell A5 in the second sheet.
Is it possible to do this using VBA? I have been attempting to do this using IF statements, but it is very messy.
I have a piece of code I am attempting to modify from here
Sub Sample()
Dim ws As Worksheet, wsTemp As Worksheet
Dim rRange As Range, rngToCopy As Range
Dim lRow As Long
Dim lRow2 As Long
Dim lCol As Long
'Find the last non-blank cell in column A(1)
lRow2 = Cells(Rows.Count, 1).End(xlUp).Row
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Combined")
With ws
'~~> Set your range for autofilter
Set rRange = .Range("A1:AR" & lRow2)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter, copy visible rows to temp sheet
With rRange
.AutoFilter Field:=9, Criteria1:="X"
'~~> This is required to get the visible range
ws.Rows("1:lRow2").EntireRow.Hidden = True
Set rngToCopy = .SpecialCells(xlCellTypeVisible).EntireRow
Set wsTemp = Sheets.Add
rngToCopy.Copy wsTemp.Range("A1")
'~~> Unhide the rows
ws.Rows("1:lRow").EntireRow.Hidden = False
End With
'~~> Remove any filters
.AutoFilterMode = False
End With
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
End Sub
But I do not know how to modify the With rRange section to meet my needs (i.e, Column I <>"X" and column J=F2
Additionally this line ws.Rows("1:lRow2").EntireRow.Hidden = True is giving me a type mismatch error
example of combined table
UPDATE
So my code now looks like this thanks to this thread
Sub AddFilter()
'
' AddFilter Macro
'
Dim rCrit1 As Range, rCrit2 As Range, rCrit3 As Range
Dim copyRange1 As Range, copyRange2 As Range, copyRange3 As Range
Dim filterRange As Range
Dim lastRow As Long
Set src = ThisWorkbook.Sheets("Combined")
Set tgt = ThisWorkbook.Sheets("Dashboard")
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
Set filterRange = src.Range("A1:Z" & lastRow)
Set copyRange1 = src.Range("A2:A" & lastRow)
Set copyRange2 = src.Range("G2:G" & lastRow)
Set copyRange3 = src.Range("I2:I" & lastRow)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rCrit1 = Worksheets("Dashboard").Range("Ref_1")
Set rCrit2 = Worksheets("Dashboard").Range("Ref_2")
Set rCrit3 = Worksheets("Dashboard").Range("Ref_3")
Sheets("Dashboard").Range("A1:C3").ClearContents
Sheets("Dashboard").Range("A1:C3").ClearFormats
Selection.AutoFilter
filterRange.AutoFilter Field:=rCrit1, Criteria1:="<>X"
filterRange.AutoFilter Field:=rCrit2, Criteria1:=rCrit_3
copyRange1.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A5")
copyRange2.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B5")
copyRange3.SpecialCells(xlCellTypeVisible).Copy tgt.Range("C5")
End Sub
However the filterRange.Autofilter line is not reading the rCrit_3 value correctly and so is not filtering based on this (Ref_3 is a named range which contains the YES cell in the first part of the problem).
Additionally the copyRange lines are giving me '1004' runtime error, but if I minimise the spreadsheet and run the code from the VBA window, it will run error free.
Can anyone shed some light on these issues?
I have an Excel sheet that contains entries for ~150 employees. Each row contains the name as well as hours worked, pay, team, etc etc etc etc. The B column in each row contains the employees name in Last,First format. About half the employees on the sheet are part time employees. What i'm trying to do is write a macro in VB that copies the entire row if the name in the B column matches one of the names of the part time employees so that one of my coworkers can simply run the macro and paste all of the rows of copied users into a new sheet each week. Here's what I currently have. (I have all of the employees names in the array however I have censored them out) I really don't understand much of the last 50% of the code. This stuff was stuff I found online and have been messing around with.
`Sub PartTime()
Dim strArray As Variant
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim NoRows As Long
Dim DestNoRows As Long
Dim I As Long
Dim J As Integer
Dim rngCells As Range
Dim rngFind As Range
Dim Found As Boolean
nameArray = Array(NAMES CENSORED)
Set wsSource = ActiveSheet
NoRows = wsSource.Range("A65536").End(xlUp).Row
DestNoRows = 1
Set wsDest = ActiveWorkbook.Worksheets.Add
For I = 1 To NoRows
Set rngCells = wsSource.Range("C" & I & ":F" & I)
Found = False
For J = 0 To UBound(strArray)
Found = Found Or Not (rngCells.Find(strArray(J)) Is Nothing)
Next J
If Found Then
rngCells.EntireRow.Copy wsDest.Range("A" & DestNoRows)
DestNoRows = DestNoRows + 1
End If
Next I
End Sub`
This code should work for what you are looking for. It is important to note that the string names in your array must be identical to that in Column B (with the exception of leading and trailing spaces), so if the names are written "LastName, FirstName" then your input data must be identical. This code could be tweaked to not have this requirement, but for now I've left it as such. Let me know if you'd prefer the code be adjusted.
Option Explicit
Sub PartTimeEmployees()
Dim NewSheet As Worksheet, CurrentSheet As Worksheet, NameArray As Variant
Set CurrentSheet = ActiveWorkbook.ActiveSheet
Set NewSheet = Sheets.Add(After:=Sheets(Worksheets.Count))
NewSheet.Name = "Part Time Employees"
NameArray = Array("NAMES CENSORED")
'Pulling headers from the first row
CurrentSheet.Rows(1).EntireRow.Copy
NewSheet.Select 'Redundant but helps avoid the occasional error
NewSheet.Cells(1, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
Dim NextRow As Long
NextRow = 2
'Writing this code to not assume that the data is continuous
Dim Count As Long
'Iterating to the end of the data in the sheet
For Count = 2 To CurrentSheet.UsedRange.Rows.Count
If Not IsEmpty(CurrentSheet.Cells(Count, 2)) Then
For Counter = 1 To UBound(NameArray)
'Performing string operations on the text will be faster than the find method
'It is also essential that the names are entered identically in your array
If UCase(Trim(CurrentSheet.Cells(Count, 2).Value)) = UCase(NameArray(Counter)) Then
CurrentSheet.Rows(Count).Copy
NewSheet.Select
NewSheet.Cells(NextRow, 1).Select
ActiveSheet.Paste
CurrentSheet.Select
NextRow = NextRow + 1
Exit For
End If
Next Counter
End If
Next Count
End Sub
No need to loop through the array if you use a Range.AutoFilter Method with the array as criteria.
See comment for each line of operational code.
Option Explicit
Sub partTimers()
Dim nameArray As Variant
'construct an array of the part-time employees' names
nameArray = Array("Trgh, Evtfk", "Mtre, Sdnrm", _
"Sfgd, Pxduj", "Lsds, Qwrml", _
"Eqrd, Oqtts")
With Worksheets("Sheet1") 'you should know what worksheet the names are on
'turn off AutoFilter is there is one already in operation
If .AutoFilterMode Then .AutoFilterMode = False
'use the 'island' of cells radiating out from A1
With .Cells(1, 1).CurrentRegion
'apply AutoFilter using array of names as criteria
.AutoFilter field:=2, Criteria1:=nameArray, Operator:=xlFilterValues
'check if there is anything to copy
If Application.Subtotal(103, .Columns(2)) > 1 Then
'copy the filtered range
.Cells.Copy
'create a new worksheet
With .Parent.Parent.Worksheets.Add(After:=Sheets(Sheets.Count))
'paste the filtered range, column widths and cell formats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
End With
End If
End With
'turn off the AutoFilter
If .AutoFilterMode Then .AutoFilterMode = False
'turn off active copy range
Application.CutCopyMode = False
End With
End Sub
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
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.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps