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
Related
I have a spreadsheet with values starting at A5 and running across to column AI, there could be any number of entries to the rows.
Row A contains an Item code (e.g. 000-0000)
I am looking to produce some code to complete the following two actions:
If column AI = yes, then copy entire row and paste below. With every copy add a sequential alphabetised letter to the code in column A (e.g. 000-0000a)
Any help would be greatly appreciated. Everything i've found expands to copying to another sheet and i'm struggling to break down the code.
Thanks
Edit:
Please see below current code I have been trying to get to work which works up to the point of copying the row however fails to paste it.
Sub NewItems(c As Range)
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
'Used for the new worksheet we are pasting into
Dim objNewSheet As Worksheet
Dim rngNextAvailbleRow As Range
'Define the worksheet with our data
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
'Dynamically define the range to the last cell.
'This doesn't include and error handling e.g. null cells
'If we are not starting in A1, then change as appropriate
Set rngNewItems = objWorksheet.Range("A5:A" & objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row)
'Now loop through all the cells in the range
For Each rngCell In rngNewItems.Cells
objWorksheet.Select
If rngCell.Value <> "Yes" Then
'select the entire row
rngCell.EntireRow.Select
'copy the selection
Selection.Copy
'Now identify and select the new sheet to paste into
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
objNewSheet.Select
'Looking at your initial question, I believe you are trying to find the next available row
Set rngNextAvailbleRow = objNewSheet.Range("A1:A" & objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row)
Range("A" & rngNextAvailbleRow.Rows.Count + 1).Select
ActiveSheet.Paste
End If
Next rngCell
objWorksheet.Select
objWorksheet.Cells(1, 1).Select
'Can do some basic error handing here
'kill all objects
If IsObject(objWorksheet) Then Set objWorksheet = Nothing
If IsObject(rngBurnDown) Then Set rngNewItems = Nothing
If IsObject(rngCell) Then Set rngCell = Nothing
If IsObject(objNewSheet) Then Set objNewSheet = Nothing
If IsObject(rngNextAvailbleRow) Then Set rngNextAvailbleRow = Nothing
End Sub
So there are lots of things to address with your code. Many of which I have touched on. But the main thing to observe is that you are testing Column A not Column AI for the presence of "Yes" - so there may not be a match hence no copy.
As the paste destination is determined by a concatenation to create a sheet name you should have a test to ensure that sheet exists.
For testing I simply ensured a sheet called Sheet1a existed, that Sheet1 cell A5 had "a" in it, and there was a "Yes" in column AI. This could be improved but is enough to get you going.
This line is looping column A:
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Whereas this line is testing column AI:
If rngCell.Offset(, 35).Value <> "Yes"
Note <> means Not Equal as opposed to =
So perhaps you wanted:
If rngCell.Offset(, 35).Value = "Yes"
Consider the following re-write.
Option Explicit
Public Sub NewItems() 'c As Range) 'I have commented out parameter which isn't currently used.
Dim rngBurnDown As Range ' not used but also not declared
Dim objWorksheet As Worksheet
Dim rngNewItems As Range
Dim rngCell As Range
Dim strPasteToSheet As String
Dim objNewSheet As Worksheet
Dim lastRowTargetSheet As Long
Set objWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim lastRow As Long
lastRow = objWorksheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rngNewItems = objWorksheet.Range("A5:A" & lastRow)
Dim copiedRange As Range 'for union
For Each rngCell In rngNewItems.Cells
'Debug.Print rngCell.Address 'shows where looping
If rngCell.Offset(, 35).Value = "Yes" Then
Set objNewSheet = ThisWorkbook.Sheets("Sheet1" & rngCell.Value)
Dim nextTargetCell As Range
lastRowTargetSheet = objNewSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set nextTargetCell = objNewSheet.Range("A" & lastRowTargetSheet)
rngCell.EntireRow.Copy nextTargetCell
Set objNewSheet = Nothing 'clear inside loop as you are setting in loop
lastRowTargetSheet = 0
Set nextTargetCell = Nothing
End If
Next rngCell
objWorksheet.Cells(1, 1).Select
End Sub
As for your lettering:
There are lots of examples online to generate these. Here is one way, by #harfang, from here:
Sub List_A_to_ZZZZ()
Dim i As Long
For i = 1 To 20 ' I have shortened this QHarr. Original end was 475254 ' ColXL("ZZZZ")
Debug.Print Right("---" & XLcL(i), 4)
Next i
End Sub
Function XLcL(ByVal N As Long) As String
Do While N > 0
XLcL = Chr(vbKeyA + (N - 1) Mod 26) & XLcL
N = (N - 1) \ 26
Loop
End Function
Function ColXL(ByVal abc As String) As Long
abc = Trim(Replace(UCase(abc), "-", ""))
Do While Len(abc)
ColXL = ColXL * 26 + (Asc(abc) - vbKeyA + 1)
abc = Mid(abc, 2)
Loop
End Function
I am trying to copy my data depending on the column value. If column R has invalid, then it should copy all information from sheet1 to sheet2.
I have below code running. Due to some reason it does not copy the last two rows of my sheet1.
I have 551 rows in sheet1 , and I have the 551 row column R as invalid. 'It checks only till 548 rows and skips the last row without moving them.
Could someone help me to fix this issue
Sub Tab()
Dim cell As Range
Dim nextrow As Long
Dim a As Double
Application.ScreenUpdating = False
' get the count of rows in column r
a = Sheets("sheet1").Cells(Rows.count, "R").End(xlUp).Row
MsgBox (a)
For Each cell In Sheets("sheet1").Range("R5:R" & a)
' if the cell in column R has invalid, then copy the entire row to another sheet
If cell.Value = "Invalid" Then
nextrow = Application.WorksheetFunction.CountA(Sheets("sheet2").Range("R:R"))
Rows(cell.Row).Copy Destination:=Sheets("sheet2").Range("A" & nextrow + 1)
End If
Next
Application.ScreenUpdating = True
End Sub
Instead of
Rows(cell.Row).Copy Destination:=Sheets("sheet2").Range("A" & nextrow + 1)
try
Sheets("sheet1").Rows(cell.Row).Copy Destination:=Sheets("sheet2").Range("A" & nextrow + 1)
Your code can be written as
Sub Demo()
Dim cell As Range
Dim nextrow As Long, a as Long
Dim srcSht As Worksheet, destSht As Worksheet
Application.ScreenUpdating = False
Set srcSht = ThisWorkbook.Sheets("Sheet3")
Set destSht = ThisWorkbook.Sheets("Sheet6")
nextrow = Application.WorksheetFunction.CountA(destSht.Range("R:R"))
With srcSht
a = .Cells(.Rows.Count, "R").End(xlUp).Row
MsgBox a
For Each cell In .Range("R5:R" & a)
' if the cell in column R has invalid, then copy the entire row to another sheet
If cell.Value = "Invalid" Then
.Rows(cell.Row).Copy Destination:=destSht.Range("A" & nextrow + 1)
nextrow = nextrow + 1
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Also instead of pasting data row by row you can also use UNION.
I will not go into the part on the variables and methodology (everyone has their way of scripting). I will respond based on your base code above, hopefully it is clear for your understanding.
Sub Tab()
Dim cell As Range
Dim nextrow As Long
Dim a As Double
Application.ScreenUpdating = False
' get the count of rows in column r
a = Sheets("sheet1").Cells(Rows.count, "R").End(xlUp).Row
MsgBox (a)
'This is assuming that you will always populate starting from the first row Range("A1") in Sheet2
nextrow = 1
For Each cell In Sheets("sheet1").Range("R5:R" & a)
' if the cell in column R has invalid, then copy the entire row to another sheet
If cell.Value = "Invalid" Then
'Use the EntireRow function to copy the whole row to the Sheet2.
'During the next iteration, it will +1 to nextrow, so the next record will be copied to Range("A2"), next Range("A3") and so forth.
cell.EntireRow.Copy Destination:=Sheets("Sheet2").Range("a" & nextrow)
nextrow = nextrow + 1
End If
Next
Application.ScreenUpdating = True
End Sub
I'm writing a macro to sort through a large file of data at work. I've inserted a blank row at the top of different section of data. I want my code to realize when a row is blank in column C, then fill in a set of headers in that row. It should then continue to find the next blank in column C. This should continue until my code finds 2 consecutive blanks, which signals the end of my data.
Currently, my code inserts the desired headers, but only in the first row of my worksheet. I believe that I need to change the loop contained inside my "Do... Loop Until" function. I just can't seem to get the correct code to achieve my desired results.
I've included a screencapture of roughly what my spreadsheet will look like.
Any help or advice is greatly appreciated.
This is the code I have so far:
Sub AddHeaders()
'Add headers below each section title
Dim Headers() As Variant
Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long, Row As Long
Application.ScreenUpdating = False 'turn this off for the macro to run a
little faster
Set wb = ActiveWorkbook
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ActiveCell = Cells(1, 3)
Headers() = Array("Item", "Configuration", "Drawing/Document Number",
"Title", "ECN", "Date", "Revisions")
' Set Do loop to stop when two consecutive empty cells are reached.
Do
For Row = 1 To LastRow 'Add a loop to go through the cells in each row?
If IsEmpty(ActiveCell) = True Then 'If row is empty, then go in and add headers
For i = LBound(Headers()) To UBound(Headers())
Cells(Row, 1 + i).Value = Headers(i)
Next i
Rows(Row).Font.Bold = True
'Loop here
End If
Next Row
ActiveCell = ActiveCell.Offset(1, 0)
Loop Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Application.ScreenUpdating = True 'turn it back on
MsgBox ("Done!")
Is this what you are looking for?
I removed the activecell stuff and used range instead.
Also removed the do loop and only use the for loop.
I think it works but Not sure. It does not look like you have on your picture but I keept your text code.
Sub AddHeaders()
'Add headers below each section title
Dim Headers() As Variant
Dim ws As Worksheet
Dim wb As Workbook
Dim LastRow As Long, Row As Long
Application.ScreenUpdating = False 'turn this off for the macro to run a
Set wb = ActiveWorkbook
LastRow = Cells(Rows.Count, 3).End(xlUp).Row
ActiveCell = Cells(1, 3)
Headers() = Array("Item", "Configuration", "Drawing/Document Number", "Title", "ECN", "Date", "Revisions")
' Set Do loop to stop when two consecutive empty cells are reached.
For Row = 1 To LastRow 'Add a loop to go through the cells in each row?
If Range("C" & Row).Value = "" Then 'If row is empty, then go in and add headers
For i = LBound(Headers()) To UBound(Headers())
Cells(Row, 1 + i).Value = Headers(i)
Next i
Rows(Row).Font.Bold = True
'Loop here
End If
Next Row
Application.ScreenUpdating = True 'turn it back on
MsgBox ("Done!")
End Sub
Edit; Include image of output of above code.
Here's how I would do it:
Sub AddHeaders()
Dim nRow As Integer
nRow = 1
Do Until Range("C" & nRow) = "" And Range("C" & nRow + 1) = ""
If Range("C" & nRow) = "" Then
Range("A" & nRow & ":D" & nRow) = "Header"
End If
nRow = nRow + 1
Loop
End Sub
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 need to select all the rows in column A that have the same the value and paste them to a new spreadsheet named with the copied name.
In the example picture when I run macro and input value Banana I should get all the rows that contain banana in column A.
I found following vba code from the internet and tried to modify it to my needs but I'm stuck:
Sub LookForAllSameValues()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 4
LSearchRow = 2
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
Uname = InputBox("Test")
ActiveWorkbook.Worksheets.Add.Name = Uname
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = Uname Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets(Uname).Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'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 A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
This code almost works. It asks user to input string to search and then it creates a new worksheet named as this one. The problem lies in the loop, I debugged the code and for some reason it just skips copy paste loop
How do I get the loop working?
Output when the code is run:
I'm assuming you're testing this on the data shown above.
Your code states that LSearch Row = 2 and therefore your search will begin in cell A2. I'd therefore assume your loop is never executing because Len(Range("A2")) equals 0 (the cell is empty) and the loop immediately exits. This also means that if any cell in column A is empty the loop will end there even if there is more data below it.
Instead try using a For..Next loop as shown below which will run from row 2 to the last used row in the active sheet, regardless of the cell contents.
Public Sub FindAndCreateNew()
Dim strFind As String
Dim i As Long, j As Long
Dim wsFind As Worksheet
Dim wsPaste As Worksheet
'Get value to search for
strFind = InputBox("Test")
'Create object reference to the current worksheet
Set wsFind = ActiveSheet
'Create a new worksheet with object reference and then rename it
Set wsPaste = Worksheets.Add
wsPaste.Name = strFind
'Paste starting at row 2 in wsPaste
j = 2
'Start searching from row 2 of wsFind, continue to end of worksheet
For i = 2 To wsFind.UsedRange.Rows.Count
If wsFind.Range("A" & i) = strFind Then
'Copy row i of wsFind to row j of wsPaste then increment j
wsFind.Range(i & ":" & i).Copy Destination:=wsPaste.Range(j & ":" & j)
j = j + 1
End If
Next i
End Sub
P.S. It's also worth noting that the use of .Select is generally avoidable and it can slow the program down considerably as well as making it less readable. For example this:
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
Could be represented with just one statement as below:
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Copy
As commented, try this:
Sub test()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rng As Range
Dim uname As String
Set sh1 = Sheet1: uname = InputBox("Input")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
If Len(uname) = 0 Then MsgBox "Invalid input": Exit Sub
Set sh2 = ThisWorkbook.Sheets.Add(after:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
On Error Resume Next
sh2.Name = uname: If Err.Number <> 0 Then MsgBox "Data already copied": _
sh2.Delete: Exit Sub
On Error GoTo 0
With sh1
.AutoFilterMode = False
Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
rng.AutoFilter 1, uname
On Error Resume Next
rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy sh2.Range("A1")
If Err.Number <> 0 Then MsgBox "Data not found" _
Else MsgBox "All matching data has been copied"
.AutoFilterMode = False
On Error GoTo 0
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub