I am trying to write a program, where I must first apply the filter to Column S with 6 possible filter values (1,2,3,4,5,6). Once the filter is applied, I must copy the last used cell in column T and paste the same in the next available (blank) visible cell in column V with the filter still being on.
Once it pastes the values successfully,if I were to apply filter again for the same value, it should repeat the same by finding the next available visible blank cell column V and paste the copied data.
The loop should keep working, For the next instance, based on the condition I might apply the filter for value 2 in the column, I must copy the last used column T data and paste in the next available visible cell in column V with the filter still being on.
I tried many possibilities like End(xlUp) it works only until copying the value from Column T and I am unable to paste it in Column V.I tried using Application.SendKeys method too. It doesn't work all the time.
The following codes that I have pasted down below, I tried copying the value of the last used cell in Column T with End(xlup), which worked all the time, the problem is all about the finding the right next available visible cell in column V to paste the same, sometime it works and sometimes it pastes in the hidden rows
enter image description here
Sub auto_filter2()
Dim ws As Worksheet
Dim ds As Worksheet
Dim SrcLastRow As Long, DestLastRow As Long
Set ws = Worksheets("PVF")
Set ds = Worksheets("Filtered")
Worksheets("PVF").Range("T4").AutoFilter Field:=19, Criteria1:="2"
MsgBox "Its Working"
Sheets("PVF").Select
SrcLastRow = Cells(Rows.Count, "T").End(xlUp).Row
Range("T" & SrcLastRow).Select
Selection.Copy
MsgBox SrcLastRow & " is the row"
Sheets("PVF").Select
Range("V5").End(xlDown).Select
Application.SendKeys "{DOWN}"
Application.SendKeys ("^v{Enter}")
ws.AutoFilterMode = False
End Sub
Sub auto_filter()
Dim ws As Worksheet
Dim ds As Worksheet
Dim SrcLastRow As Long, DestLastRow As Long
Set ws = Worksheets("PVF")
Set ds = Worksheets("Filtered")
Worksheets("PVF").Range("T4").AutoFilter Field:=19, Criteria1:="4"
MsgBox "Its Working"
Sheets("PVF").Select
SrcLastRow = Cells(Rows.Count, "T").End(xlUp).Row
Range("T" & SrcLastRow).Select
Selection.Copy
MsgBox SrcLastRow & " is the row"
Sheets("Filtered").Select
DestLastRow = Cells(Rows.Count, "C").End(xlUp).Row
Range("C" & DestLastRow).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Dim cel As Range
With Sheets("PVF")
Set cel = .AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible)(1, 1)
If cel = "" Then
.Cells(cel.Row, "V") = Sheets("Filtered").Range("C3")
Else
MsgBox (" Non- empty box")
End If
End With
ws.AutoFilterMode = False
End Sub
I hope to solve this problem soon. Many thanks for your solutions in advance.
Related
I'm trying to do something weird, and it's maybe not the only way, and it's probably the wrong one. I want to iterate on the visible cells (which is the result of the AutoFilter function of VBA).
Here's what I've done before, and it works, but not how I want :
Sheets("MySheet").Range("$A$3:$AI$10191").AutoFilter Field:=12, Criteria1:=myList, Operator:=xlFilterValues . myList is a list of String, like this : Dim myList() as String
Currently, this does not fit with what I want : I do not want this to take the blank cells, and I also want the myList() content be taken approximativly (something like ""&myList&"").
To do that, I tried one simple line of code and it works :
Sheets("MySheet").Range("$A$3:$AI$10191").AutoFilter Field:=12, Criteria1:="*"&myList(0)&"*", Operator:=xlFilterValues
My problem is : I want to do that for all the elements of my list. I've been thinking about iterating through my list (myList) but everytime I'm doing a new iteration, it simply does not take the result of the previous iteration . In reality, I just want to filter on the "already filtered" rows...
I already tried the method with .SpecialCells(xlCellTypeVisible) but it takes all the cells, and not only the visible one.... (here's the full code with visible cells : Sheets("MySheet").Range("$A$3:$AI$10191").SpecialCells(xlCellTypeVisible).AutoFilter Field:=12, Criteria1:="*"&myList(0)&"*", Operator:=xlFilterValues)
I've been thinking on something like that :
For i =0 to UBound(myList)
Sheets("MySheet").Range("$A$3:$AI$10191").SpecialCells(xlCellTypeVisible).AutoFilter Field:=12, Criteria1:="*"&myList(i)&"*", Operator:=xlFilterValues
Next i
But it just filters following the last .AutoFilter rule. (it filters on i=UBound(myList) , because each .AutoFilter is erasing the job of the previous one... )
If you have any ideas... Thanks, Clément.
To try the Advanced Filter, you can give this a try.
Tweak it as required...
Sub AdvancedFilter()
Dim wsData As Worksheet, wsCriteria As Worksheet
Dim myList() As String
Dim i As Long, lr As Long
Dim Rng As Range, Cell As Range
Application.ScreenUpdating = False
Set wsData = Sheets("MySheet")
If wsData.FilterMode Then wsData.ShowAllData
lr = wsData.UsedRange.Rows.Count
On Error Resume Next
Set wsCriteria = Sheets("Criteria")
wsCriteria.Cells.Clear
On Error GoTo 0
If wsCriteria Is Nothing Then
Sheets.Add.Name = "Criteria"
Set wsCriteria = ActiveSheet
End If
'Assuming myList has already been populated
'Writing the column header (column 12) on Criteria Sheet in A1
wsCriteria.Cells(1, 1) = wsData.Cells(1, 12)
'Adding wild card to each element in myList
For i = 1 To UBound(myList)
myList(i) = "*" & myList(i) & "*"
Next i
'Writing myList on Criteria Sheet
wsCriteria.Range("A2").Resize(UBound(myList)).Value = Application.Transpose(myList)
'Using Advanced Filter on Data Sheet with Criteria on Criteria Sheet
wsData.Range("A1").CurrentRegion.AdvancedFilter xlFilterInPlace, wsCriteria.Range("A1").CurrentRegion
'Deleting the Criteria Sheet as it is not required now
Application.DisplayAlerts = False
wsCriteria.Delete
Application.DisplayAlerts = True
'Setting Rng as visible cells in column A
On Error Resume Next
Set Rng = wsData.Range("A2:A" & lr).SpecialCells(xlCellTypeVisible)
If Not Rng Is Nothing Then
For Each Cell In Rng
'Do your stuff here with visible range
Next Cell
End If
If wsData.FilterMode Then wsData.ShowAllData
Application.ScreenUpdating = True
End Sub
I'm practising VBA and I need some help / correction for my code.
In this task I'm creating a search tool which looks up each worksheet for the selected value from a combobox. Each result is listed on the first page.
Problems:
In the code I defined the .Find method in to a range rFound. On each worksheet the searched value is at column D. I would like to copy the row from column B to E. I've commented an attempt how did I tried to select that range, with offset but I receive an error. Why and how to fix that?
When I want to paste (list) the results I want it to start from the 1st page 3rd row column K. After running the code it selects the right target but pastes nothing. How to fix this?
I've also made some attempts to copy the document header after each search result, but I commented them out, please ignore lines with getOwner.
Dim ws As Worksheet, OutputWs As Worksheet, wsLists As Worksheet
Dim rFound As Range ', getOwner As Range
Dim strName As String
Dim count As Long, LastRow As Long
Dim IsValueFound As Boolean
'Dim cboSelectName As ComboBox
Dim a As String
IsValueFound = False
Set OutputWs = Worksheets("Teszt") '---->change the sheet name as required
LastRow = OutputWs.Cells(Rows.count, "A").End(xlUp).Row
Set wsLists = Worksheets("Lists")
a = ComboBox1.Value
On Error Resume Next
strName = a
If strName = "" Then Exit Sub
For Each ws In Worksheets
If ws.Name <> "Output" Then
With ws.UsedRange
Set rFound = .Find(What:=strName, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
If Not rFound Is Nothing Then
Application.Goto rFound, True
IsValueFound = True
'MsgBox rFound.Row
rFound.EntireRow.Copy
'Rfound keres - rFound.Range(rFound(Offset(-2,")),rFound.Offset(1,"")).Copy ' ---> This is a suggestion
OutputWs.Cells(LastRow + 2, 11).PasteSpecial xlPasteAll
'getOwner.Range(K2, R2).Copy ' attempt to copy the header for each search result
'getOwner.Cells(LastRow + 1, 6).Paste
Application.CutCopyMode = False
LastRow = LastRow + 1
End If
End With
End If
Next ws
On Error GoTo 0
If IsValueFound Then
OutputWs.Select
MsgBox "Search Complete!"
Else
MsgBox "Value not found"
End If
You are selection entire row but you are pasting it to the column K. If you copy entire row, you can only copy it to column A. That's why it is not working. So I suggest you to work on Offset part.
In Offset, first part is rows, second part is columns.
you can do something like that,
Dim sth as Range
set sth = .range(.rfound.offset(0,-2),.rfound.offset(0,1)).copy
But I am not sure of it. Not very good at that.
I have a worksheet that has multiple value and what I would like to do is search say column "B" for a value and when it finds it to copy the complete row and paste it somewhere else. I have a similar function to do this but it stops after it finds the first one which is fine for the situation that I am using it in but for this case I need it to copy all that match. below is the code that im using at the moment that only gives me one value
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.value
lastRow = wks1.range("A" & Rows.Count).End(xlUp).row
Set rangeList = wks1.range("A2:A" & lastRow)
On Error Resume Next
row = Application.WorksheetFunction.Match(strSelect, wks1.Columns(1), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
Thanks
I would suggest to load data into array first and then operate on this array instead of operating on cells and using Worksheet functions.
'(...)
Dim data As Variant
Dim i As Long
'(...)
If ExpIDComboBox.ListIndex <> -1 Then
strSelect = ExpIDComboBox.Value
lastRow = wks1.Range("A" & Rows.Count).End(xlUp).Row
'Load data to array instead of operating on worksheet cells directly - it will improve performance.
data = wks1.Range("A2:A" & lastRow)
'Iterate through all the values loaded in this array ...
For i = LBound(data, 1) To UBound(data, 1)
'... and check if they are equal to string [strSelect].
If data(i, 1) = strSelect Then
'Row i is match, put the code here to copy it to the new destination.
End If
Next i
End If
I have used the Range.Find() method to search each row. For each row of data which it finds, where the value you enter matches the value in column G, it will copy this data to Sheet2. You will need to amend the Sheet variable names.
Option Explicit
Sub copyAll()
Dim rngFound As Range, destSheet As Worksheet, findSheet As Worksheet, wb As Workbook
Dim strSelect As String, firstFind As String
Set wb = ThisWorkbook
Set findSheet = wb.Sheets("Sheet1")
Set destSheet = wb.Sheets("Sheet2")
strSelect = ExpIDComboBox.Value
Application.ScreenUpdating = False
With findSheet
Set rngFound = .Columns(7).Find(strSelect, LookIn:=xlValues)
If Not rngFound Is Nothing Then
firstFind = rngFound.Address
Do
.Range(.Cells(rngFound.Row, 1), .Cells(rngFound.Row, _
.Cells(rngFound.Row, .Columns.Count).End(xlToLeft).Column)).Copy
destSheet.Cells(destSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteAll
Set rngFound = .Columns(2).Find(strSelect, LookIn:=xlValues, After:=.Range(rngFound.Address))
Loop While firstFind <> rngFound.Address
End If
End With
Application.ScreenUpdating = True
End Sub
I've assumed you will have data between columns A:G?
Otherwise you can just amend the .Copy and .PasteSpecial methods to fit your requirements.
Thanks for your replys. I tired to use both methods but for some reason they did not seem to work. They did not give me an error they just did not produce anything.#mielk I understand what you mean about using an array to do this and it will be a lot faster and more efficent but I dont have enfough VBA knowledge to debug as to why it did not work. I tried other methods and finally got it working and thought it might be usefull in the future for anybody else trying to get this to work. Thanks once again for your answers :)
Private Sub SearchButton2_Click()
Dim domainRange As range, listRange As range, selectedString As String, lastRow As Long, ws, wks3 As Excel.Worksheet, row, i As Long
Set wks3 = Worksheets("Exceptions") '<----- WorkSheet for getting exceptions
If DomainComboBox.ListIndex <> -1 Then '<----- check that a domain has been selected
selectedString = DomainComboBox.value
lastRow = wks3.range("A" & Rows.Count).End(xlUp).row ' finds the last full row
Set listRange = wks3.range("G2:G" & lastRow) 'sets the range from the top to the last row to search
i = 2
'used to only create a new sheet is something is found
On Error Resume Next
row = Application.WorksheetFunction.Match(selectedString, wks3.Columns(7), 0) ' searches the worksheet to find a match
On Error GoTo 0
If row Then
For Each ws In Sheets
Application.DisplayAlerts = False
If (ws.Name = "Search Results") Then ws.Delete 'deletes any worksheet called search results
Next
Application.DisplayAlerts = True
Set ws = Sheets.Add(After:=Sheets(Sheets.Count)) 'makes a new sheet at the end of all current sheets
ws.Name = "Search Results" 'renames the worksheet to search results
wks3.Rows(1).EntireRow.Copy 'copys the headers from the exceptions page
ws.Paste (ws.Cells(, 1)) 'pastes the row into the search results page
For Each domainRange In listRange ' goes through every value in worksheet trying to match what has been selected
If domainRange.value = selectedString Then
wks3.Rows(i).EntireRow.Copy ' copys the row that results was found in
emptyRow = WorksheetFunction.CountA(ws.range("A:A")) + 1 ' finds next empty row
ws.Paste (ws.Cells(emptyRow, 1)) 'pastes the contents
End If
i = i + 1 'moves onto the next row
ws.range("A1:Q2").Columns.AutoFit 'auto fit the columns width depending on what is in the a1 to q1 cell
ws.range("A1:Q1").Cells.Interior.ColorIndex = (37) 'fills the header with a colour
Application.CutCopyMode = False 'closes the paste funtion to stop manual pasting
Next domainRange ' goes to next value
Else
MsgBox "No Results", vbInformation, "No Results" 'display messgae box if nothing is found
Exit Sub
End If
End If
End Sub
Thanks.
N.B. this is not the most efficent way of doing this read mielk's answer and the other answer as they are better if you can get them working.
I am attempting to do a simple copy row, paste row within a workbook. I've searched threads and tried changing my code multiple times to no avail.
The one that comes closest to working is this but it only copies a single instance of matching criteria.
I am trying to create a loop that will copy all of the rows that has a match in one of the columns.
So, if 8 columns, each row with matching value in column 7 should copy to a named sheet.
Sub test()
Set MR = Sheets("Main").Range("H1:H1000")
Dim WOLastRow As Long, Iter As Long
For Each cell In MR
If cell.Value = "X" Then
cell.EntireRow.Copy
Sheets("X").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Y" Then
cell.EntireRow.Copy
Sheets("Y").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "Z" Then
cell.EntireRow.Copy
Sheets("Z").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
If cell.Value = "AB" Then
cell.EntireRow.Copy
Sheets("AB").Range("A" & Rows.Count).End(xlUp).PasteSpecial
End If
Application.CutCopyMode = False
Next
End Sub
I like this because I need to target multiple destination sheets with different criteria but I need all rows that match criteria to copy over.
EDITED CODE IN RESPONSE TO NEW REQUEST:
The code below will copy all of the rows in Sheet Main and paste them into the corresponding worksheets based on the value in Column 7.
Do note: If there is a value in Column 7 that does NOT match to an existing sheet name, the code will throw an error. Modify the code to handle that exception.
Let me know of any additional needed help.
Sub CopyStuff()
Dim wsMain As Worksheet
Dim wsPaste As Worksheet
Dim rngCopy As Range
Dim nLastRow As Long
Dim nPasteRow As Long
Dim rngCell As Range
Dim ws As Worksheet
Const COLUMN_TO_LOOP As Integer = 7
Application.ScreenUpdating = False
Set wsMain = Worksheets("Main")
nLastRow = wsMain.Cells(Rows.Count, 1).End(xlUp).Row
Set rngCopy = wsMain.Range("A2:H" & nLastRow)
For Each ws In ActiveWorkbook.Worksheets
If UCase(ws.Name) = "MAIN" Then
'Do Nothing for now
Else
Intersect(ws.UsedRange, ws.Columns("A:H")).ClearContents
End If
Next ws
For Each rngCell In Intersect(rngCopy, Columns(COLUMN_TO_LOOP))
On Error Resume Next
Set wsPaste = Worksheets(rngCell.Value)
On Error GoTo 0
If wsPaste Is Nothing Then
MsgBox ("Sheet name: " & rngCell.Value & " does not exist")
Else
nPasteRow = wsPaste.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsMain.Range("A" & rngCell.Row).Resize(, 8).Copy wsPaste.Cells(nPasteRow, 1)
End If
Set wsPaste = Nothing
Next rngCell
Application.ScreenUpdating = True
End Sub
Your current code is pasting to the same row in each sheet over and over, to the last row with a value in column A. Range("A" & Rows.Count).End(xlUp) says, roughly "go to the very bottom of the spreadsheet in column A, and then jump up from there to the next lowest cell in column A with contents," which gets you back to the same cell each time.
Instead, you could use lines of the pattern:
Sheets("X").Range("A" & Sheets("X").UsedRange.Rows.Count + 1).PasteSpecial
Where UsedRange is a range containing all of the cells on the sheet with data in them. The + 1 puts you on the following row.
You could make this a little prettier using With:
With Sheets("X")
.Range("A" & .UsedRange.Rows.Count + 1).PasteSpecial
End With
I am trying to use a macro to clean up data files and only copy on Sheet2 what is most relevant.
I have written the code to find the row I want the data to be copied from. However I can only copy the row itself and not the range underneath. Please note I need the range to go from that row to the last column and last row as the size of the matriz always varies.
s N s N s N s N s rpm
Linear Real Linear Real Linear Real Linear Real Linear Amplitude
0.0000030 9853.66 0.0000030 5951.83 0.0000030 533.48 0.0000030 476.15 0.0000030 2150.16
0.0000226 9848.63 0.0000226 5948.19 0.0000226 557.02 0.0000226 488.60 0.0000226 2150.16
0.0000421 9826.05 0.0000421 5956.22 0.0000421 615.94 0.0000421 480.75 0.0000421 2150.15
0.0000616 9829.72 0.0000616 5989.72 0.0000616 642.59 0.0000616 476.77 0.0000616 2150.15
So basically the code below finds that first row and copies it in Sheet2. I need the macro to also select the range underneath and copy it onto Sheet2. Please can you help me finishing off the script?
Sub SearchForRawData()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 1
LSearchRow = 1
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
'If value in column A = "s", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = "s" Then
'Select row and range in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets("Sheet2").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Select all Raw Data underneath found Row to Copy
'Paste all Raw Data into Sheet 2
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A1
Application.CutCopyMode = False
Range("A1").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error has occured"
End Sub
You don't need a loop for this if you want to copy the row that has the "s" and everything below it to the target sheet. The following sub finds the row with the "s" in column A and then copies that row and everything below it to the target sheet.
Note that you should always avoid selecting or activating anything in VBA code, and that the normal way to copy and paste relies on selecting. If you use the syntax I've included here, the clipboard is not used and the target sheet does not need to be selected.
Sub CopyRowAndBelowToTarget()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim match As Range
Set wb = ThisWorkbook
Set src = wb.Sheets("Sheet1")
Set tgt = wb.Sheets("Sheet2")
Dim lastCopyRow As Long
Dim lastPasteRow As Long
Dim lastCol As Long
Dim matchRow As Long
Dim findMe As String
' specify what we're searching for
findMe = "s"
' find our search string in column A (1)
Set match = src.Columns(1).Find(What:=findMe, After:=src.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
' figure out what row our search string is on
matchRow = match.Row
' get the last row and column with data so we know how much to copy
lastCopyRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
lastCol = src.Cells(1, src.Columns.Count).End(xlToLeft).Column
' find out where on our target sheet we should paste the results
lastPasteRow = tgt.Range("A" & src.Rows.Count).End(xlUp).Row
' use copy/paste syntax that doesn't use the clipboard
' and doesn't select or activate
src.Range(Cells(matchRow, 1), Cells(lastCopyRow, lastCol)).Copy _
tgt.Range("A" & lastPasteRow)
End Sub
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
So firstly you don't acutally need the CStr, vba will cast numbers to strings by itself, i.e. Range(LSearchRow & ":" & LSearchRow) should work fine.
To find how many rows down to go use the end function of the range object:
bottomRow = Range("A" & LSearchRow).End(xldown).Row
Do the same for the column
lastCol = Range("A" & LSearchRow).End(xlleft).column
Now to copy:
Range("A" & LSearchRow & ":" & lastCol & bottomRow).Copy
However if you have empty cells inthe middleof the data then instead of using End(xldown), start at the bottom of the sheet and look up:
bottomRow = Range("A1000000").End(xlup).Row
etc