I've got a spreadsheet with data from column A:AA. I'm trying to copy over all of the data from sheet CycleCountResearch in "workbook-a" to CycleCountResearch sheet in "workbook-b". All of the data except for column AA copy's over. Column AA contains the filename, so that when it is copied over from workbook a to workbook b, the user can look at the data in workbook b and know which file the data came from. Is there any recommendation on how to fix column AA not copying over?
Here is the code so far:
Sub Export()
Dim FileName As String
FileName = "\\InventoryControlDatabase\DoNotOpen\DoNotOpenDCAtest.xlsx"
'Call function to check if the file is open
If IsFileOpen(FileName) = False Then
Application.ScreenUpdating = False
Worksheets("CycleCountResearch").Unprotect "123"
Dim LR As Long
Dim src As Workbook
LR = Worksheets("CycleCountResearch").Cells(Rows.Count, "B").End(xlUp).Row
Set src = Workbooks.Open("\\InventoryControlDatabase\DoNotOpen\DoNotOpenDCAtest.xlsx")
ThisWorkbook.Worksheets("CycleCountResearch").AutoFilterMode = False
ThisWorkbook.Worksheets("CycleCountResearch").Range("A4:AA" & LR).AutoFilter Field:=23, Criteria1:="Done", _
Operator:=xlFilterValues
On Error Resume Next
ThisWorkbook.Worksheets("CycleCountResearch").Range("A5:AA" & LR).SpecialCells(xlCellTypeVisible).Copy
src.Activate
src.Worksheets("CycleCountResearch").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'src.Worksheets("CycleCountCompleted").UsedRange.RemoveDuplicates Columns:=1, Header:=xlYes
Workbooks("DoNotOpenDCA.xlsx").Close SaveChanges:=True
Application.ScreenUpdating = True
Call UpdateMasterLog
Call ClearUpdates
ThisWorkbook.Worksheets("CycleCountResearch").Range("K2:K2").ClearContents
'Clears the name of the user editing the sheet
Else
MsgBox "Someone else is saving. Please wait a moment and try again"
Exit Sub
End If
End Sub
Backup Data
This is how I see it. Read through it before running it because you may have to rearrange some lines in the Finishing Touches part (e.g. ClearUpdates, UpdateMasterLogs).
The best advice from it should be about using variables. They will not slow down the code but will make it more readable, the obvious example being the variables srg, sdrg, and sdfrg.
Option Explicit
Sub ExportData()
Const dFilePath As String _
= "\\InventoryControlDatabase\DoNotOpen\DoNotOpenDCAtest.xlsx"
'Call function to check if the file is open
If Not IsFileOpen(dFilePath) Then ' source workbook is closed
Application.ScreenUpdating = False
' Source
Dim swb As Workbook: Set swb = ThisWorkbook
Dim sws As Worksheet: Set sws = swb.Worksheets("CycleCountResearch")
sws.Unprotect "123"
sws.AutoFilterMode = False
Dim slRow As Long: slRow = sws.Range("B" & sws.Rows.Count).End(xlUp).Row
' Source Range (has headers)
Dim srg As Range: Set srg = sws.Range("A4:AA" & slRow)
srg.AutoFilter Field:=23, Criteria1:="Done" ' '23' is 'W'
' Source Data Range (no headers)
Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
' Source Data Filtered Range
Dim sdfrg As Range
On Error Resume Next ' prevent error if no cells
Set sdfrg = sdrg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not sdfrg Is Nothing Then
' Destination
Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
Dim dws As Worksheet: Set dws = dwb.Worksheets("CycleCountResearch")
Dim dCell As Range
Set dCell = dws.Range("A" & dws.Rows.Count).End(xlUp).Offset(1)
sdfrg.Copy¸
dCell.PasteSpecial Paste:=xlPasteValues
'dwb.Worksheets("CycleCountCompleted").UsedRange.RemoveDuplicates _
Columns:=1, Header:=xlYes
dwb.Close SaveChanges:=True
' Finishing Touches
UpdateMasterLog
ClearUpdates
'Clear the name of the user editing the sheet
sws.Range("K2:K2").ClearContents
sws.AutoFilterMode = False
sws.Protect "123"
Application.ScreenUpdating = True '
MsgBox "Data exported.", vbInformation
Else ' no filtered data
sws.AutoFilterMode = False
MsgBox "No filtered data.", vbCritical
'Exit Sub
End If
Else ' source workbook is open
MsgBox "Someone else is saving. Please, try again later.", vbExclamation
'Exit Sub
End If
End Sub
Related
I am trying to delete a row if the value I check is 0.
So far I did almost the exact same in another set of workbooks, and it went just fine.
Both cases involve getting the agency's name from the startup workbook, then opening the first workbook of the set that needs deletion, looping through it and deleting what needs to be deleted, closing it and moving on to the next one (here I go from 2 to 2 because there's no need to go through all of them just yet)
I did my homework and looked it up beforehand. No, not my table nor my sheet nor my workbook nor any range is protected. Yes, I made sure to activate the workbook I want to affect, and it has only one sheet in it.
Using .Select works, deleting manually isn't possible. It seems a cell is locked, but even unlocking it doesn't allow me to manually delete the row.
here it's unlocked.
Edit - I tried running it with the original set of workbooks, and it worked just fine (the one I'm working with is a copy of the original)
Sub PetitTas()
deb = Now()
For i = 2 To 2
Workbooks("dimensionnement technos 2").Activate
Agence = Cells(i, 24)
Workbooks.Open "C:\Users\QNS691\Documents\Excel\par agence 2\" & Agence & ".xlsx"
Workbooks(Agence).Activate
For j = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(j, 14) = 0 Then
Rows(j).EntireRow.Delete
End If
Next j
Workbooks(Agence).Close SaveChanges:=True
Next i
MsgBox deb & " " & Now()
End Sub
I am running out of ideas, please help!
Delete Entire Rows (Union)
Sub PetitTas()
Const FolderPath As String = "C:\Users\QNS691\Documents\Excel\par agence 2\"
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets("Feuil1")
Dim sfCell As Range: Set sfCell = sws.Range("X2")
Dim slCell As Range: Set slCell = sfCell.Resize( _
sws.Rows.Count - sfCell.Row + 1).Find("*", , xlFormulas, , , xlPrevious)
Dim srg As Range: Set srg = sws.Range(sfCell, slCell)
Application.ScreenUpdating = False
Dim sCell As Range
Dim Agency As String
Dim FilePath As String
Dim dwb As Workbook
Dim dws As Worksheet
Dim durg As Range
Dim drg As Range
Dim dCell As Range
For Each sCell In srg.Cells
Agency = CStr(sCell.Value)
If Len(Agency) > 0 Then
FilePath = FolderPath & Agency & ".xlsx"
If Len(Dir(FilePath)) > 0 Then ' check if the file exists...
Set dwb = Workbooks.Open(FilePath) ' ... only then open it
Set dws = dwb.Worksheets(1) ' the one and only
Set drg = dws.Range("N2", dws.Cells( _
dws.Cells(dws.Rows.Count, "A").End(xlUp).Row, "N"))
For Each dCell In drg.Cells
If IsNumeric(dCell) Then
If dCell.Value = 0 Then
If durg Is Nothing Then
Set durg = dCell
Else
Set durg = Union(durg, dCell)
End If
End If
End If
Next dCell
If durg Is Nothing Then
dwb.Close SaveChanges:=False
Else
durg.EntireRow.Delete
Set durg = Nothing
dwb.Close SaveChanges:=True
End If
End If
End If
Next sCell
Application.ScreenUpdating = True
MsgBox "'PetitTas' is done.", vbInformation
End Sub
Overall you shouldn't be relying on the active sheet or the .Activate method. You should look at how-to-avoid-using-select-in-excel-vba
With that, explicitly use the Workbook and Worksheet when working with any Range or Cell.
Now your deletion is removing rows that your loop is depending on, so one fix is to loop backwards.
Below is my quick fixes to your code, but note it isn't tested.
Option Explicit
Public Sub PetitTas()
Dim deb As Date ' Was missing
deb = Now()
Dim i As Long ' Was missing
For i = 2 To 2
' Use the specific worksheet reference.
' Using activate isn't reliable and
' hurts performance
Dim agence As Variant
agence = Workbooks("dimensionnement technos 2") _
.Worksheets(1) _
.Cells(i, 24)
' Capture your workbook into a variable for the
' same reason above, activate is not your friend
' in most cases. Only time is when you need to display
' a user a specific sheet.
Dim wb As Workbook
Set wb = Workbooks.Open( _
"C:\Users\QNS691\Documents\Excel\par agence 2\" & _
agence & ".xlsx" _
)
' Use a with statement to capture your
' worksheet, that way `.Cells` is pointing
' explicitly to the correct sheet.
With wb.Worksheets(1)
Dim j As Long ' Was missing
' When deleting in a loop, either capture
' all ranges into a variable a delete after loop
' or step backwards. I steped backwards for this demo
' for simplicity, but single deletion is more performant
For j = .Cells(.Rows.Count, 1).End(xlUp).Row To 2 Step -1
If .Cells(j, 14) = 0 Then
.Rows(j).EntireRow.Delete
End If
Next j
End With
wb.Close SaveChanges:=True
Next i
MsgBox deb & " " & Now()
End Sub
How can a range of cells be copied from one workbook to another? The code below does not work. I believe there is something wrong with how the range of cells are selected: sht1.Range("A1:D1").Select
Sub ImportData()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Application.ScreenUpdating = False
Set wkb1 = ThisWorkbook
Set wkb2 = Workbooks.Open("C:\Users\Temp\Desktop\MyExcelSheet.xlsm")
Set sht1 = wkb1.Sheets("Data")
Set sht2 = wkb2.Sheets("Summary")
'Function to clear the existing data. Doesn't work.
sht1.Range("A1:D1").Select
sht1.Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
' Copies data from the "Summary" sheet.
sht2.Range("O6:P102").Copy
sht2.Range("O6").Select
sht2.Range(Selection, Selection.End(xlToRight)).Select
sht2.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy ' Copies all of the highlighted cells.
sht1.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wkb2.Close True
Application.ScreenUpdating = True
MsgBox "Complete"
End Sub
Replace:
sht1.Range("A1:D1").Select
sht1.Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
With
sht1.Range("A1:D" & Range("D1").End(xlDown).Row).Clear
Unless you specifically want to manually highlight the cells and then run the macro, this solution works.
This replacement code will now highlight every cell between "A1:D1" however, XlDown is only applied on the column "D".
Copy the Values of a Range
Option Explicit
Sub ImportData()
' Source (open, read from & close)
Const sFilePath As String = "C:\Users\Temp\Desktop\MyExcelSheet.xlsm"
Const sName As String = "Summary"
Const sFirstRowAddress As String = "O6:R6"
' Destination (write to & save)
Const dName As String = "Data"
Const dFirstCellAddress As String = "A1"
' Source
Dim swb As Workbook: Set swb = Workbooks.Open(sFilePath)
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim srg As Range
With sws.Range(sFirstRowAddress)
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then
MsgBox "No data found.", vbCritical
Exit Sub
End If
Set srg = .Resize(lCell.Row - .Row + 1)
End With
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
' Clear & copy.
With dws.Range(dFirstCellAddress).Resize(, srg.Columns.Count)
' Clear previous data.
.Resize(dws.Rows.Count - .Row + 1).Clear
' Copy values by assignment.
.Resize(srg.Rows.Count).Value = srg.Value
End With
' Save & close.
swb.Close SaveChanges:=False
'dwb.Save
' Inform.
MsgBox "Values copied.", vbInformation
End Sub
With the help of others, I was able to build this working code. I do however need help in adding conditions to it.
Before the worksheets are moved to a new file it must first check if a file of the same name already exist. If one does exist, then it should just update it (paste new data at the bottom). If none exist, then it should create one (which is what this code is doing)
Sub ExportSheets()
' Export segregated sheets to individual workbooks
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sPath As String, sAddress As String, wsCur As Worksheet
Dim arrNoMoveSh, mtchSh
Dim sht As String
Dim x As Range
Dim rng As Range
Dim last As Long
Dim ControllerTab As Worksheet
Dim ControllerTabBase As Range
Set ControllerTab = ThisWorkbook.Worksheets("Controller")
Set ControllerTabBase = ControllerTab.Range("B1")
' --Creates an array of the sheet names to not be moved
arrNoMoveSh = Split("Read Me,Validations,Controller,MTI Data,Other", ",")
' --Store path of this workbook
sPath = ThisWorkbook.path & Application.PathSeparator
' --Loop through worksheets
For Each wsCur In ThisWorkbook.Worksheets
mtchSh = Application.Match(wsCur.Name, arrNoMoveSh, 0)
If IsError(mtchSh) Then 'no sheet names found in the array
wsCur.Copy 'create a new workbook for the sheet to be copied!!!
' --Specifies the sheet name in which the data is stored
sht = wsCur.Name
last = Sheets(sht).Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:P" & last)
Sheets(sht).Range("N1:N" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("BB1"), Unique:=True
For Each x In Range([BB2], Cells(Rows.Count, "BB").End(xlUp))
With rng
.AutoFilter Field:=14, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
Sheets(sht).Activate
Sheets(sht).Delete
ActiveWorkbook.SaveAs sPath & wsCur.Name & ".xlsx"
ActiveWorkbook.Close SaveChanges:=True
End If
Next wsCur
Application.ScreenUpdating = True
Application.DisplayAlerts = True
ControllerTab.Activate
ControllerTabBase.Select
End Sub
Export Worksheets to Workbooks
Option Explicit
Sub ExportWorksheets()
Dim siws As Worksheet: Set siws = ThisWorkbook.Worksheets("Controller")
Dim siCell As Range: Set siCell = siws.Range("B1")
Dim Exceptions() As String
Exceptions = Split("Read Me,Validations,Controller,MTI Data,Other", ",")
Dim sPath As String: sPath = ThisWorkbook.Path & Application.PathSeparator
Application.ScreenUpdating = False
Dim sws As Worksheet
Dim sName As String
Dim dwb As Workbook
Dim dws As Workbook
Dim drg As Range
Dim dCell As Range
Dim dlRow As Long
Dim dFilePath As String
Dim dName As String
Dim dnws As Worksheet ' existing worksheet
Dim ddrg As Range ' excluding headers
For Each sws In ThisWorkbook.Worksheets
sName = sws.Name
If IsError(Application.Match(sName, Exceptions, 0)) Then ' not found
dFilePath = sPath & sName & ".xlsx"
If Len(Dir(dFilePath)) = 0 Then ' file doesn't exist
' Copy to workbook.
sws.Copy
Set dwb = Workbooks(Workbooks.Count)
Set dws = dwb.Worksheets(sName)
dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
Set drg = dws.Range("A1:P" & dlRow)
' Advance Filter
dws.Range("N1:N" & dlRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=dws.Range("BB1"), Unique:=True
' Copy to worksheets.
For Each dCell In dws.Range("BB2", _
dws.Cells(dws.Rows.Count, "BB").End(xlUp)).Cells
dName = dCell.Value
With drg
.AutoFilter Field:=14, Criteria1:=dName
.SpecialCells(xlCellTypeVisible).Copy
dwb.Worksheets.Add(After:=dwb.Sheets( _
dwb.Sheets.Count)).Name = dName
ActiveSheet.Paste
End With
Next dCell
' Save.
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
dwb.SaveAs Filename:=dFilePath
dwb.Close SaveChanges:=False
Else ' file exists
' Copy to workbook.
Set dwb = Workbooks.Open(dFilePath)
sws.Copy Before:=dwb.Sheets(1)
Set dws = dwb.Worksheets(sName)
dlRow = dws.Cells(dws.Rows.Count, "A").End(xlUp).Row
Set drg = dws.Range("A1:P" & dlRow)
Set ddrg = dws.Range("A2:P" & dlRow)
' Advanced Filter
dws.Range("N1:N" & dlRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=dws.Range("BB1"), Unique:=True
' Copy to worksheets.
For Each dCell In dws.Range("BB2", _
dws.Cells(dws.Rows.Count, "BB").End(xlUp)).Cells
dName = dCell.Value
On Error Resume Next
Set dnws = dwb.Worksheets(dName)
On Error GoTo 0
If dnws Is Nothing Then ' worksheet doesn't exist...
With drg ' ... the same as when file doesn't exist
.AutoFilter Field:=14, Criteria1:=dName
.SpecialCells(xlCellTypeVisible).Copy
dwb.Worksheets.Add(After:=dwb.Sheets( _
dwb.Sheets.Count)).Name = dName
ActiveSheet.Paste
End With
Else ' worksheet already exists
drg.AutoFilter Field:=14, Criteria1:=dName
ddrg.SpecialCells(xlCellTypeVisible).Copy _
dnws.Cells(dnws.Rows.Count, "A").End(xlUp).Offset(1)
Set dnws = Nothing
End If
Next dCell
' Save.
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
dwb.Close SaveChanges:=True
End If
'Else ' is in the exceptions list; do nothing
End If
Next sws
' Finishing Touches
siws.Select
siCell.Select
Application.ScreenUpdating = True
MsgBox "Worksheets exported.", vbInformation
End Sub
Here's a function to determine whether a file currently exists:
Private Function FileExists(FileName As String) As Boolean
On Error Resume Next
FileExists = CBool(FileLen(FileName) + 1)
End Function
Function FileExists(FileName As String) As Boolean
FileExists = Len(Dir(FileName)) > 0
End Function
Usage
I would add the FileExists(FileName) clase to the existing If statement.
FileName = sPath & wsCur.Name & ".xlsx"
If IsError(mtchSh) And Not FileExists(FileName) Then 'no sheet names found in the array
I am trying to copy only data from one workbook into a new one, but with only four of the existing worksheets. The code below allows me to successfully copy all worksheets to a new workbook. This worked fine before, but now I only want to copy sheet 2-7, thus excluding sheet 1.
This is done by a user copying data into sheet 1 and the data will be populated to sheets 2-5. Sheet 6 & 7 contains metadata which will be the same for all new workbooks. To be able to import the copied data, I need a new workbook with sheets 2-7.
Sub Button1_Click()
Dim Output As Workbook
Dim Current As String
Dim FileName As String
Set Output = ThisWorkbook
Current = ThisWorkbook.FullName
Application.DisplayAlerts = False
Dim SH As Worksheet
For Each SH In Output.Worksheets
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
FileName = ThisWorkbook.Path & "\" & "Generic name.xlsx" 'Change name as needed
Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook
Workbooks.Open Current
Output.Close
Application.DisplayAlerts = True
End Sub
Any suggestions on how improve the code to only copy specified sheets, or to exclude sheet 1?
Copy a Set of Worksheets to Another Workbook
Option Explicit
Sub Button1_Click()
' Constants
Const dFileName As String = "Generic name.xlsx"
Dim DoNotCopy As Variant: DoNotCopy = Array(1) ' add more: Array(1, 7, 8)
Const ConversionWorksheetsCount As Long = 4
' Write the names of the desired worksheets to an array.
Dim swb As Workbook: Set swb = ThisWorkbook
Dim swsCount As Long: swsCount = swb.Worksheets.Count
Dim dwsNames() As String: ReDim dwsNames(1 To swsCount)
Dim sws As Worksheet
Dim sCount As Long
Dim dCount As Long
For Each sws In swb.Worksheets
sCount = sCount + 1
If IsError(Application.Match(sCount, DoNotCopy, 0)) Then
dCount = dCount + 1
dwsNames(dCount) = sws.Name
' Else ' worksheet index found in the 'DoNotCopy' array.
End If
Next sws
If dCount = 0 Then
MsgBox "No worksheets found.", vbCritical
Exit Sub
End If
If dCount < swsCount Then
ReDim Preserve dwsNames(1 To dCount)
End If
Application.ScreenUpdating = False
' Copy the desired worksheets to a new (destination) workbook.
swb.Worksheets(dwsNames).Copy
Dim dwb As Workbook: Set dwb = ActiveWorkbook
' Do the conversions.
Dim dws As Worksheet
Dim n As Long
For n = 1 To ConversionWorksheetsCount
On Error Resume Next
Set dws = dwb.Worksheets(n)
On Error GoTo 0
If Not dws Is Nothing Then ' destination worksheet exists
dws.Activate ' needed for '.Cells(1).Select'
With dws.UsedRange
.Copy
.PasteSpecial xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
.Cells(1).Select ' cosmetics
End With
Set dws = Nothing
'Else ' destination worksheet doesn't exist
End If
Next n
'dwb.Worksheets(1).Activate ' cosmetics
' Save the new (destination) workbook.
Dim dFilePath As String: dFilePath = swb.Path & "\" & dFileName
Application.DisplayAlerts = False ' overwrite without confirmation
dwb.SaveAs dFilePath, xlOpenXMLWorkbook
Application.DisplayAlerts = True
dwb.Close
' Note that you never modified the source. It's in the same state as before.
Application.ScreenUpdating = True
MsgBox "Workbook created.", vbInformation
End Sub
Add an If statement after the For Each loop to exclude Sheet1:
For Each SH In Output.Worksheets
If SH.Name <> "Sheet1" Then
SH.UsedRange.Copy
SH.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End If
Next
I am trying to apply filter to the data and copy the filtered data to an other sheet and delete the filtered rows in base sheet.
I am facing error as 'cannot use the command on overlapping selection'
When I try to delete the filtered rows in base sheet using
specialcells(xlcelltypevisible).entirerow.delete
Sheets("analysis").select
Sourcecol=1
VCurrLength = cells(rows.count, sourcecol).end(clip).row
Activesheet.range("$A$1:$W$"& VCurrLength).autofilter field:=7, criteria1:= "ZP"
Range ("A1").select
Selection.end(xldown).select
If selection.row<1000000 then
Range("A2:w"& VCurrLength).specialcells(xlcelltypevisible).copy
Sheets("temp").select
Activesheet.paste
Sheets("analysis").select
Range("A2:w"& VCurrLength).specialcells(xlcelltypevisible).select
Selection.entirerow.delete
Endif
Backup Data
Option Explicit
Sub backupData()
Dim Success As Boolean
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("analysis")
Dim sLR As Long: sLR = sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
Dim srg As Range: Set srg = sws.Range("A1:W" & sLR)
Application.ScreenUpdating = False
If sws.AutoFilterMode Then
sws.AutoFilterMode = False
End If
srg.AutoFilter field:=7, Criteria1:="ZP"
If WorksheetFunction.Subtotal(103, srg.Cells.Resize(, 1)) > 1 Then
Dim dws As Worksheet: Set dws = wb.Worksheets("temp")
Dim dcell As Range
Set dcell = dws.Cells(dws.Rows.Count, "A").End(xlUp).Offset(1)
Dim frg As Range
Set frg = srg.Resize(srg.Rows.Count - 1).Offset(1) _
.SpecialCells(xlCellTypeVisible)
frg.Copy dcell
frg.EntireRow.Delete
If Not sws Is ActiveSheet Then
sws.Activate
End If
srg.Cells(1).Select
Success = True
End If
sws.AutoFilterMode = False
Application.ScreenUpdating = True
If Success Then
MsgBox "Data updated.", vbInformation, "Success"
Else
MsgBox "No updates available.", vbExclamation, "Nope"
End If
End Sub