What I want to achieve is to copy data from WS1 to WS3 based on certain criteria.
I have 2 worksheets:
WS1 = RAW DATA
WS2 = ATLAS DATA
In columns A of both there are unique identifiers. What I want to do is to create WS3=Reconciliation. Then look up values in WS2 against WS1. Where a match is found I want to copy row(s) from WS1 to WS3 that all
I have reverse engineered some code and came up with one below
Sub CopyAndPaste()
Dim x As String, CpyRng As Range
Dim mFIND As Range, mFIRST As Range
With Sheets("RAW DATA")
Range("A:A").Select
On Error Resume Next
End With
With Sheets("ATLAS DATA")
Set mFIND = .Range("A:A").Find(x, LookIn:=xlValues, LookAt:=xlWhole)
If Not mFIND Is Nothing Then
Set CpyRng = mFIND
Set mFIRST = mFIND
Do
Set CpyRng = Union(CpyRng, mFIND)
Set mFIND = .Range("A:A").FindNext(mFIND)
Loop Until mFIND.Address = mFIRST.Address
CpyRng.EntireRow.Copy Sheets("Rec").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End With
End Sub
Based on your description of your problem; try this
Option Explicit
Sub CopyAndPaste()
Application.ScreenUpdating = False
Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long, cnt As Long
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Set ws1 = ActiveWorkbook.Sheets("RAW DATA")
Set ws2 = ActiveWorkbook.Sheets("ATLAS DATA")
Set ws3 = ActiveWorkbook.Sheets("Reconciliation")
lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
lastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
cnt = 1
For i = 1 To lastRow1
For j = 1 To lastRow2
If StrComp(CStr(ws2.Range("A" & j).Value), _
CStr(ws1.Range("A" & i).Value), _
vbTextCompare) = 0 Then
ws1.Activate
ws1.Rows(i).Select
Selection.Copy
ws3.Activate
ws3.Range("A" & cnt).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Application.CutCopyMode = False
cnt = cnt + 1
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Related
This code works, but it puts the values at the bottom of Sheet2(Table2), instead of next available row in table2. Any suggestions would be appreciated. Thanks
https://drive.google.com/file/d/19fZ6GLGtVNd13I-GTgLVjnfKlzrwx05U/view?usp=sharing
Sub Macro()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet2")
Dim LastRow As Long
Dim s As Long
Dim myRow As Long
s = ws.Range("A" & Application.Rows.Count).End(xlUp).Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "I").End(xlUp).Row
For myRow = 2 To LastRow
If Sheets("Sheet1").Cells(myRow, "I") = "INACTIVE" Then
ws.Range("A" & s + 1) = Sheets("Sheet1").Cells(myRow, "A")
ws.Range("B" & s + 1) = Sheets("Sheet1").Cells(myRow, "B")
ws.Range("C" & s + 1) = Sheets("Sheet1").Cells(myRow, "C")
ws.Range("D" & s + 1) = Sheets("Sheet1").Cells(myRow, "I")
End If
Next myRow
End Sub
Copying Data From One Excel Table to Another
Dealing with Excel tables in VBA can be quite tricky. This is a simple user-friendly version. You could dive much deeper into it by using (an array of) the table headers in the loop and whatnot.
Option Explicit
Sub Macro()
Dim sws As Worksheet: Set sws = ThisWorkbook.Worksheets("Sheet1")
Dim stbl As ListObject: Set stbl = sws.ListObjects("Table1")
Dim dws As Worksheet: Set dws = ThisWorkbook.Worksheets("Sheet2")
Dim dtbl As ListObject: Set dtbl = dws.ListObjects("Table2")
Dim sCell As Range
Dim srrg As Range
Dim drrg As Range
Dim r As Long
For Each sCell In stbl.ListColumns("Status").DataBodyRange
r = r + 1
If StrComp(CStr(sCell.Value), "INACTIVE", vbTextCompare) = 0 Then
Set srrg = stbl.ListRows(r).Range
Set drrg = dtbl.ListRows.Add.Range
drrg.Cells(1).Value = srrg.Cells(1).Value
drrg.Cells(2).Value = srrg.Cells(2).Value
drrg.Cells(3).Value = srrg.Cells(3).Value
drrg.Cells(4).Value = srrg.Cells(9).Value
End If
Next sCell
End Sub
the below code should work as s variable is inside the loop.
P.S.
Updated the code to match your example.
Also, the sheet2 has table, so the last row was not detected correctly by End(xlUp).Row
The problem was also with myRow =2
Sub Macro()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim LastRow As Long
Dim s As Long
Dim myRow As Long
LastRow = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, "I").End(xlUp).Row
For myRow = 1 To LastRow
s = ws.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
If ws1.Cells(myRow, "I") = "INACTIVE" Then
ws.Range("A" & s & ":C" & s) = ws1.Range("A" & myRow & ":C" & myRow).Value
ws.Range("D" & s) = "INACTIVE"
End If
Next myRow
MsgBox "OK"
End Sub
I have data in a table, where I compare two columns J and T. The values which J and T can take include A2B, APL, BGF, CMA, among others (see code).
If these values are equal, copy row i into the sheet which has the name of the cells just checked.
If these values are not equal, copy row i into the sheets which have the name of the cells just checked.
Example: Compare J2 and T2,
Suppose J2=T2=BGF then copy row 2 and paste into sheet("BGF")
Next, compare J3 and T3
Suppose J3=BGF and T3=CMA, copy row 3 and paste into sheet(BGF) and sheet(CMA)
Next, compare J4 and T4
Suppose J4=Nothing and T4=CMA, copy row 4 and paste into sheet CMA
the only other combination is where Ji has a value and Ti is empty.
Problem: When running this code, If J3=BGF and T3= nothing (its empty), then the line is not copied to any sheet.
Here's the code
Sub Sortdata()
'step 1 clear all data
Sheets("A2B").Cells.ClearContents
Sheets("APL").Cells.ClearContents
Sheets("BGF").Cells.ClearContents
Sheets("CMA").Cells.ClearContents
Sheets("K Line").Cells.ClearContents
Sheets("MacAndrews").Cells.ClearContents
Sheets("Maersk").Cells.ClearContents
Sheets("OOCL").Cells.ClearContents
Sheets("OPDR").Cells.ClearContents
Sheets("Samskip").Cells.ClearContents
Sheets("Unifeeder").Cells.ClearContents
Dim i As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
With Worksheets("All Data")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRow
If IsEmpty(.Range("J" & i)) Then
Set ws1 = Nothing
Else
Set ws1 = Worksheets(.Range("J" & i).Value)
End If
If IsEmpty(.Range("T" & i)) Then
Set ws2 = Nothing
Else
Set ws2 = Worksheets(.Range("T" & i).Value)
End If
If ws1 Is Nothing Then
If Not ws2 Is Nothing Then
CopyToWs ws2, .Rows(i)
End If
ElseIf ws2 Is Nothing Then
If Not ws1 Is Nothing Then
CopyToWs ws1, .Rows(i)
End If
Else
CopyToWs ws1, Rows(i)
If ws1.Name <> ws2.Name Then
CopyToWs ws2, .Rows(i)
End If
End If
Next
End With
End Sub
Sub CopyToWs(ws As Worksheet, rng As Range)
rng.Copy
ws.Cells(ws.Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow.PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Please try this code. It takes a slightly different approach to what you tried but it gets the job done, I think.
Option Explicit
Sub Sortdata()
' Variatus #STO 20 Jan 2020
Const WsNames As String = "A2B,APL,BGF,CMA,K Line,MacAndrews," & _
"Maersk,OOCL,OPDR,Samskip,Unifeeder"
Dim WsS As Worksheet ' Source
Dim Ws As Worksheet
Dim Rng As Range
Dim Rt As Long ' target row
Dim LastRow As Long
Dim J As Long, T As Long
Dim Tmp As Variant, PrevTmp As Variant
Dim R As Long, C As Long
'step 1 clear all data
Tmp = Split(WsNames, ",")
For R = LBound(Tmp) To UBound(Tmp)
On Error Resume Next
Worksheets(Tmp(R)).Cells.ClearContents
Next R
Application.ScreenUpdating = False
Set WsS = Worksheets("All Data")
With WsS
J = .Columns("J").Column
T = .Columns("T").Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For R = 2 To LastRow
PrevTmp = ""
For C = J To T Step T - J
Tmp = .Cells(R, C).Value
If Len(Tmp) And Tmp <> PrevTmp Then
On Error Resume Next
Set Ws = Worksheets(Tmp)
If Err = 0 Then
Set Rng = .Range(.Cells(R, 1), .Cells(R, .Columns.Count).End(xlToLeft))
With Ws
Rt = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 2)
Rng.Copy Destination:=Ws.Cells(Rt, 1)
End With
End If
End If
PrevTmp = Tmp
Next C
If R Mod 25 = 0 Then Application.StatusBar = "Currently processing row " & R
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
I think you will be able to find your way through it and make any required modifications. Let me know if you require any assistance.
I work a cumulative report that grows daily up to about 150,000 rows of data. I am trying to run a macro that will move the data from one defined sheet to another defined sheet. Unfortunately, it is taking an extremely long time and leaves my Excel window frozen.
I have been staring at this code trying to make it work for our needs for so long that I haven't tried anything different.
Sub Move()
Application.ScreenUpdating = False
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
lastrow = Worksheets("From TaxWise").UsedRange.Rows.Count
lastrow2 = Worksheets("State").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = lastrow To 2 Step -1
If Not Range("L" & r).Value = "US" Then
Rows(r).Cut Destination:=Worksheets("State").Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
On Error Resume Next
ActiveWorkbook.Worksheets("From TaxWise").Columns("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
Not sure what I need to adjust as I feel my current code is running through 150,000 records line by line to identify, cut and move.
This code took about two seconds to run on 150000 records with about 3000 equal to US.
You'll need to alter it to match your setup. eg: Names of the various worksheets; cell ranges in case your tables don't start at A1, slightly different syntax if your data is in Excel Tables rather than just ranges, etc
It uses Excel's built-in autofilter
The destination sheet has all of the lines except for those with US.
Option Explicit
Sub noUS()
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim rSrc As Range, rDest As Range
Const filterColumn As Long = 4 'Change to 12 for column L
Dim LRC() As Long
Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
Set rDest = wsDest.Cells(1, 1)
wsDest.Cells.Clear
With wsSrc
'get last row and column of the source worksheet
LRC = LastRowCol(.Name)
'set the range
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
'set the filter
'first turn it off
.AutoFilterMode = False
'now set it for the range
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="<>US", _
visibledropdown:=False
End With
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rDest
'turn off the autofilter
wsSrc.AutoFilterMode = False
End Sub
'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
Dim WS As Worksheet, R As Range
Dim LastRow As Long, LastCol As Long
Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Not R Is Nothing Then
LastRow = R.Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function
And if you want to have a separate sheet with the US rows, you can insert the following before the end of the Sub:
'now get the US rows
With wsSrc
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
.AutoFilterMode = False
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="US", _
visibledropdown:=False
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rUS
.AutoFilterMode = False
End With
I prefer to maintain the original data, rather than deleting stuff from the source. But, if you like, after you've done the above, and you are happy with the result, merely delete wsSrc
Edit
The above code modified so you wind up with, what I think you want, which is worksheets("State") containing all of the non-US items; and worksheets("From TaxWise") containing all of the US items.
Instead of deleting non-contiguous rows, a very slow process, we filter the rows we want to a new worksheet; delete the original worksheet, and rename the new sheet.
Don't try this at home without a backup of your original data.
Option Explicit
Sub noUS()
Dim wsSrc As Worksheet, wsDest As Worksheet, wsUS As Worksheet
Dim rSrc As Range, rDest As Range, rUS As Range
Const filterColumn As Long = 12
Dim LRC() As Long
Set wsSrc = Worksheets("From TaxWise")
Set wsDest = Worksheets("State")
Set rDest = wsDest.Cells(1, 1)
wsDest.Cells.Clear
With wsSrc
'get last row and column of the source worksheet
LRC = LastRowCol(.Name)
'set the range
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
'set the filter
'first turn it off
.AutoFilterMode = False
'now set it for the range
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="<>US", _
visibledropdown:=False
End With
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rDest
'turn off the autofilter
wsSrc.AutoFilterMode = False
'now get the US rows, may need to add worksheet
On Error Resume Next
Set wsUS = Worksheets("US")
If Err.Number = 9 Then
Worksheets.Add
ActiveSheet.Name = "US"
End If
Set wsUS = Worksheets("US")
Set rUS = wsUS.Cells(1, 1)
With wsSrc
Set rSrc = .Range(.Cells(1, 1), .Cells(LRC(0), LRC(1)))
.AutoFilterMode = False
rSrc.AutoFilter _
field:=filterColumn, _
Criteria1:="US", _
visibledropdown:=False
Set rSrc = rSrc.SpecialCells(xlCellTypeVisible)
rSrc.Copy rUS
.AutoFilterMode = False
End With
'Delete Taxwise and rename US sheets
Application.DisplayAlerts = False
wsSrc.Delete
wsUS.Name = "From TaxWise"
Application.DisplayAlerts = True
End Sub
'--------------------------------------------
Private Function LastRowCol(Worksht As String) As Long()
Application.Volatile
Dim WS As Worksheet, R As Range
Dim LastRow As Long, LastCol As Long
Dim L(1) As Long
Set WS = Worksheets(Worksht)
With WS
Set R = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Not R Is Nothing Then
LastRow = R.Row
LastCol = .Cells.Find(what:="*", after:=.Cells(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, _
searchdirection:=xlPrevious).Column
Else
LastRow = 1
LastCol = 1
End If
End With
L(0) = LastRow
L(1) = LastCol
LastRowCol = L
End Function
You can filter and work with visible cells or you can avoid deleting rows inside your loop.
Say, for instance, that you have 500 cells that are not equal to US. You will then have 500 instances of copy/paste & deletions. This is highly inneficient.
Instead, add your target cells to a Union (collection of cells) and then outside of the loop, perform your operations on the collection. No matter how many rows are being targeted, you will have just one instance of copy, one instance of paste, and one instance of deletion.
Sub Moving()
Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("From TaxWise")
Dim ps As Worksheet: Set ps = ThisWorkbook.Sheets("State")
Dim MoveMe As Range, myCell As Range, LR2 As Long
Dim LR As Long: LR = cs.Range("L" & cs.Rows.Count).End(xlUp).Row
For Each myCell In cs.Range("L2:L" & LR)
If myCell <> "US" Then
If Not MoveMe Is Nothing Then
Set MoveMe = Union(MoveMe, myCell)
Else
Set MoveMe = myCell
End If
End If
Next myCell
If Not MoveMe Is Nothing Then
LR2 = ps.Range("A" & ps.Rows.Count).End(xlUp).Row
MoveMe.EntireRow.Copy
ps.Range("A" & LR2).PasteSpecial xlPasteValues
MoveMe.EntireRow.Delete
End If
End Sub
Move Rows
Union Version
Option Explicit
Sub Move()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Dim rngU As Range, r As Long, lastrow2 As Long, lastrow As Long
On Error GoTo ProcedureExit
With Worksheets("From Taxwise")
lastrow = .Cells(.Rows.Count, "L").End(xlUp).row
For r = 2 To lastrow
If Not .Range("L" & r).Value = "US" Then
If Not rngU Is Nothing Then
Set rngU = Union(rngU, .Cells(r, 1))
Else
Set rngU = .Cells(r, 1)
End If
End If
Next
End With
If Not rngU Is Nothing Then
With Worksheets("State")
lastrow2 = .Cells(.Rows.Count, "L").End(xlUp).row
rngU.EntireRow.Copy .Range("A" & lastrow2 + 1)
rngU.EntireRow.Delete
End With
Set rngU = Nothing
End If
ProcedureExit:
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub
I am currently trying to filter data and paste it into another sheet to a certain range but it is only posting the latest data row. How do I fix the code so that it selects all the rows with the code word and pastes it into the other sheet.
This is my code:
Private Sub CommandButton1_Click()
Dim lastrow As Long, i As Long
lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If Sheets("sheet1").Cells(i, 1) = "pp" Then
Sheets("sheet1").Range(Cells(i, 2), Cells(i, 5)).Copy
ActiveSheet.Paste Destination:=Worksheets("Sheet5").Range("A11:A22")
End If
Next
End Sub
I think this is what you want.
Private Sub CommandButton1_Click()
Dim ws1 as Worksheet: Set ws1 = Thisworkbook.Sheets("Sheet1")
Dim ws2 as Worksheet: Set ws2 = Thisworkbook.Sheets("Sheet5")
Dim LRow1 As Long, LRow2 as Long, i As Long
LRow1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
LRow2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
For i = 2 To lastrow
If ws1.Cells(i, 1) = "pp" Then
ws1.Range(Cells(i, 1), Cells(i, 5)).Copy
ws2.Range("A" & LRow + 1).PasteSpecial xlPasteValues
End If
Next
End Sub
Here is a more effecient method using a For Each loop and one instance of Copy/Paste instead of 1 iteration for every matched cell.
Option Explicit
Sub Copy()
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("Sheet1")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("Sheet2")
Dim TargetRange As Range, TargetCell As Range, CopyRange As Range
Set TargetRange = ws1.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
For Each TargetCell In TargetRange
If TargetCell = "pp" Then
If CopyRange Is Nothing Then
Set CopyRange = TargetCell.Resize(1, 4)
Else
Set CopyRange = Union(CopyRange, TargetCell.Resize(1, 4))
End If
End If
Next TargetCell
CopyRange.Copy
ws2.Range("A" & ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row).PasteSpecial xlPasteValuesAndNumberFormats
End Sub
Another method would be to apply a filter for your target value pp and then copy/paste visible cells.
If the sheet name is "Central " (with a space at the end of the word), zone = "Central" returns an error and the sheet cannot be activated.
How do i correct this?
dim wb1, wb2, wb3 as workbook
set wb1 = activeworkbook 'the macro file
dim ws1, ws2 as worksheet
set ws1 = Sheets("Central Zone")
set ws2 = Sheets("Eastern Zone")
For x = 1 To 2
If x = 1 Then
Set ws = ws1
zone = "Central"
End If
If x = 2 Then
Set ws = ws2
zone = "East"
End If
wb2.Sheets(zone).Activate 'wb2 is source file 1. I have wb3, wb4, etc
Selection.EntireColumn.Hidden = False
Range("A1").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.EntireRow.Select
Selection.Copy
wb1.Activate
ws.Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Next x
It's allways recommended to stay away from Activate, Selection, Select and all other "relatives". Instead use referenced objects, like Sheets, and `Ranges.
The code below is a little "quick and dirty" but it should give you the result you want
Code
Option Explicit
Sub CopyCentralSheets()
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, Sht As Worksheet, ws As Worksheet
Dim LastRow As Long, LastColumn As Long, PasteRow As Long, x As Long
Set wb1 = ThisWorkbook ' this macro file
'Set wb2 = Workbooks("temp.xlsx") 'for my debug tests only
Set ws1 = wb1.Sheets("Central Zone")
Set ws2 = wb1.Sheets("Eastern Zone")
For x = 1 To 2
If x = 1 Then
For Each Sht In wb2.Worksheets
If Sht.Name Like "Central*" Then
Set ws = Sht
End If
Next Sht
Else
If x = 2 Then
For Each Sht In wb2.Worksheets
If Sht.Name = "East" Then
Set ws = Sht
End If
Next Sht
End If
End If
With ws
LastRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
LastColumn = .UsedRange.Columns(.UsedRange.Columns.Count).Column
.Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Copy
End With
If x = 1 Then
With ws1
PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & PasteRow + 1).PasteSpecial xlValues
End With
Else
If x = 2 Then
With ws2
PasteRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A" & PasteRow + 1).PasteSpecial xlValues
End With
End If
End If
Next x
End Sub