VBA Can I consolidate all codes to do step by step after one button is used? Currently I have to use 4 buttons and it does not always work properly

B

Bellaanima7

New Member
Joined
Jul 23, 2020
Messages
22
Office Version
  1. 365
Platform
  1. Windows
Hi,

Can I consolidate all codes to do step by step after one button is used? Currently I have to use 4 buttons and it does not always work properly

First button upload the CSV file from other source to "Source data" :

VBA Code: 
Sub Load_Survey_Data1()

Dim ws As Worksheet
Dim filestring As String

' step 1 clear out current source data tab
'step 2 open file dialog to select csv file name and store this
'fullpath is a global variable
'step 3 import the data into "source data" tab
'step 4 load into TEMPLATE - ONB FILE only new records

'step 1

    Sheets("Source data").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Control page").Select
   
   
'step 2

'Display a Dialog Box that allows to select a single file.
'The path for the file picked will be stored in fullpath variable
  With Application.FileDialog(msoFileDialogFilePicker)
        'Makes sure the user can select only one file
        .AllowMultiSelect = False
        'Filter to just the following types of files to narrow down selection options
        .Filters.Add "Excel Files", "*.csv", 1
        'Show the dialog box
        .Show
       
        'Store in fullpath variable
       fullpath = .SelectedItems.Item(1)
    End With
'step 3


'now load the csv file into this sheet

' testimportcsv Macro
'
'filestring = "Text;" & fullpath
'
    Set ws = ActiveWorkbook.Sheets("Source Data") 'set to current worksheet name

   ' strFile = Application.GetOpenFilename("Text Files (*.csv),*.csv", , "Please select text file...")

    'With ws.QueryTables.Add(Connection:="TEXT;" & fullpath, Destination:=ws.Range("A1"))
     '   .PreserveFormatting = True
      '  .TextFileParseType = xlDelimited
       ' .TextFileCommaDelimiter = True
        ' .Refresh
    'End With
'ADD copy and paste code here

    Workbooks.Open FileName:=fullpath
    Cells.Select
    Selection.Copy
    'ActiveWindow.Close
        ws.Activate
    Sheets("Source data").Select
    Cells.Select
    ActiveSheet.Paste
    Do Until IsEmpty(ActiveCell.Offset(a, 0)) And IsEmpty(ActiveCell.Offset(a + 1, 0))

    On Error GoTo ErrorHandler
   
    Jotform_Field = ActiveCell.Offset(a, 0).Value
    Amazon_Field = ActiveCell.Offset(a, 1).Value
   
    Sheets("Source data").Select
    Rows(1).Select
    Set TargetC = ActiveSheet.Cells.Find(Jotform_Field, LookAt:=xlWhole)
    TargetC.Select
    TargetC.Value = Amazon_Field
   
ErrorHandler:
    Resume Continue
Continue:
    a = a + 1
    Sheets("Alignments").Select
Loop
    Columns("A:EU").Select
    Columns("A:EU").EntireColumn.AutoFit
   
    'Addcode to check if new or old record
   
   

    Sheets("Control page").Select

'step4 load new records into TEMPLATE - ONB FILE
'use uniqueflag Sureynumber

Dim sht As Worksheet
Dim fnd As Variant
Dim rplc As Variant

fnd = "ß"
rplc = "ß"

'Store a specfic sheet to a variable
  Set sht = Sheets("Source data")

'Perform the Find/Replace All
  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
   
fnd = "Ü"
rplc = "Ü"

'Store a specfic sheet to a variable
  Set sht = Sheets("Source data")

'Perform the Find/Replace All
  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False

fnd = "Ö"
rplc = "Ö"

'Store a specfic sheet to a variable
  Set sht = Sheets("Source data")

'Perform the Find/Replace All
  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
   
fnd = "ö"
rplc = "ö"

'Store a specfic sheet to a variable
  Set sht = Sheets("Source data")

'Perform the Find/Replace All
  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False

fnd = "ü"
rplc = "ü"

'Store a specfic sheet to a variable
  Set sht = Sheets("Source data")

'Perform the Find/Replace All
  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False
   
fnd = "ä"
rplc = "ä"

'Store a specfic sheet to a variable
  Set sht = Sheets("Source data")

'Perform the Find/Replace All
  sht.Cells.Replace What:=fnd, Replacement:=rplc, _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False

Sheets("Source data").Select
    Range("EJ2").Select
    ActiveCell.FormulaR1C1 = "3.0"
    Range("EJ2").Select
     Selection.NumberFormat = "#.0"
  
End Sub

Second button reformatting uploaded data:

VBA Code: 
Sub Reformat_JotForm_Extract()

Dim rng, TargetC, Current_Cell As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False
UKCompose_PDF_URL

'NEED to define last row programmaticaly, currently limited to row 500

Sheets("Final").Select
Range("C2:EI1000").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents

'L = Range("1:1").Cells.SpecialCells(xlCellTypeConstants).Count + 1
Range("c1").Select

Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(0, 1)) And IsEmpty(ActiveCell.Offset(0, 2))
   
    On Error GoTo ErrorHandler
    Sheets("Final").Select
    Set Current_Cell = ActiveCell
    Field_Name = ActiveCell.Value
   

    
    Sheets("Source data").Select
    Set TargetC = ActiveSheet.Cells.Find(Field_Name, LookAt:=xlWhole)
    TargetC.Select
    Col_Index = ActiveCell.Column
    Columns(Col_Index).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Final").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Current_Cell.Select
   
ErrorHandler:
    Resume Continue
Continue:
    Sheets("Final").Select
    ActiveCell.Offset(0, 1).Select

Loop
'remove this check we will do this as we email
'Alignments

Application.ScreenUpdating = True
Application.DisplayAlerts = True

Sheets("Control page").Select

End Sub

Sub Alignments()
Dim rng, TargetC, Current_Cell As Range

Sheets("Final_Aligned").Select
Cells.Select
Selection.Clear
Sheets("Final").Select
Range("c1:JF500").Copy
Sheets("Final_Aligned").Select
Range("a1:JF500").Select ' iz changed to dk
ActiveSheet.Paste

Range("W2:AX2000").Select
    Selection.NumberFormat = "hh:mm:ss;@"
Range("BL2:BL2000").Select
    Selection.NumberFormat = "hh:mm:ss;@"
Range("BM2:BM2000").Select
    Selection.NumberFormat = "dd/mm/yyyy"
Range("CM2:CM2000").Select
    Selection.NumberFormat = "dd/mm/yyyy"
   

End Sub

Third one has a form I have to click, but would like to change it to just making a change to "Validated" without using the form and avoiding clicking:


VBA Code: 
Dim currentrow As Long
Dim fullpath As String

Private Const C_SURVEYNUMBER = 71
Private Const C_AddrLineOne = 5
Private Const C_AddrLineTwo = 6
Private Const C_City = 8
Private Const C_Region = 9
Private Const C_District = 10
Private Const C_Postcode = 11
Private Const C_CtyCode = 12
Private Const C_Timezone = 15
Private Const C_Lat = 13
Private Const C_Long = 14
Private Const C_UploadSpd = 89
Private Const C_DownloadSpd = 90
Private Const C_LockerAccess = 107
Private Const C_DelInfo = 110
Private Const C_Parking = 111
Private Const C_KioskDirections = 19
Private Const C_SurveyStatus = 2
Private Const C_PDFLink = 3

Private Const C_Validation = 142



Private Sub Label83_Click()

End Sub

Private Sub NextBtn_Click()
Dim Lastrow As Long
Dim statuscheck As String
Dim a As Integer

Lastrow = Sheets("Final").Cells(Rows.Count, 1).End(xlUp).Row
If currentrow = Lastrow Then
    MsgBox "You are in the last row"
    Exit Sub
End If
currentrow = currentrow + 1
' loop for only new records

statuscheck = Sheets("Final").Cells(currentrow, 2)
Do While statuscheck <> "New / Pending Validation"
currentrow = currentrow + 1
statuscheck = Sheets("Final").Cells(currentrow, 2)
'If currentrow = lastrow Then
'   MsgBox "You are in the last row"
  '  Exit Sub
'End If
a = a + 1
If a > 107 Then End
Loop

ValidateTxt0 = Sheets("Final").Cells(currentrow, C_SURVEYNUMBER)
ValidateTxt1 = Sheets("Final").Cells(currentrow, C_AddrLineOne)
ValidateTxt2 = Sheets("Final").Cells(currentrow, C_AddrLineTwo)
ValidateTxt3 = Sheets("Final").Cells(currentrow, C_City)
ValidateTxt4 = Sheets("Final").Cells(currentrow, C_Region)
ValidateTxt5 = Sheets("Final").Cells(currentrow, C_District)
ValidateTxt6 = Sheets("Final").Cells(currentrow, C_Postcode)
ValidateTxt7 = Sheets("Final").Cells(currentrow, C_CtyCode)
ValidateTxt8 = Sheets("Final").Cells(currentrow, C_Timezone)
ValidateTxt9 = Sheets("Final").Cells(currentrow, C_Lat)
ValidateTxt10 = Sheets("Final").Cells(currentrow, C_Long)
ValidateTxt11 = Sheets("Final").Cells(currentrow, C_UploadSpd)
ValidateTxt12 = Sheets("Final").Cells(currentrow, C_LockerAccess)
ValidateTxt13 = Sheets("Final").Cells(currentrow, C_DelInfo)
ValidateTxt14 = Sheets("Final").Cells(currentrow, C_Parking)
ValidateTxt15 = Sheets("Final").Cells(currentrow, C_KioskDirections)
ValidateTxt16 = Sheets("Final").Cells(currentrow, C_DownloadSpd)
SurveyStatusTxt17 = Sheets("Final").Cells(currentrow, C_SurveyStatus)
F_PDFLink = Sheets("Final").Cells(currentrow, C_PDFLink)

End Sub

Private Sub BackBtn_Click()

If currentrow = 2 Then
    MsgBox "You are in the first row"
    Exit Sub
End If
currentrow = currentrow - 1

ValidateTxt0 = Sheets("Final").Cells(currentrow, C_SURVEYNUMBER)
ValidateTxt1 = Sheets("Final").Cells(currentrow, C_AddrLineOne)
ValidateTxt2 = Sheets("Final").Cells(currentrow, C_AddrLineTwo)
ValidateTxt3 = Sheets("Final").Cells(currentrow, C_City)
ValidateTxt4 = Sheets("Final").Cells(currentrow, C_Region)
ValidateTxt5 = Sheets("Final").Cells(currentrow, C_District)
ValidateTxt6 = Sheets("Final").Cells(currentrow, C_Postcode)
ValidateTxt7 = Sheets("Final").Cells(currentrow, C_CtyCode)
ValidateTxt8 = Sheets("Final").Cells(currentrow, C_Timezone)
ValidateTxt9 = Sheets("Final").Cells(currentrow, C_Lat)
ValidateTxt10 = Sheets("Final").Cells(currentrow, C_Long)
ValidateTxt11 = Sheets("Final").Cells(currentrow, C_UploadSpd)
ValidateTxt12 = Sheets("Final").Cells(currentrow, C_LockerAccess)
ValidateTxt13 = Sheets("Final").Cells(currentrow, C_DelInfo)
ValidateTxt14 = Sheets("Final").Cells(currentrow, C_Parking)
ValidateTxt15 = Sheets("Final").Cells(currentrow, C_KioskDirections)
ValidateTxt16 = Sheets("Final").Cells(currentrow, C_DownloadSpd)
SurveyStatusTxt17 = Sheets("Final").Cells(currentrow, C_SurveyStatus)
F_PDFLink = Sheets("Final").Cells(currentrow, C_PDFLink)

End Sub

Private Sub LatLongBtn_Click()
Dim latlong As String

latlong = "[URL='https://www.google.co.uk/maps/place/']Google Maps[/URL]" + CStr(ValidateTxt9.Value) + "," + CStr(ValidateTxt10.Value)
'MsgBox latlong

ActiveWorkbook.FollowHyperlink _
      Address:=latlong, _
      NewWindow:=True

End Sub



Private Sub SaveContinueBtn_Click()
If SurveyPhotosChkBox.Value = False Then
    MsgBox "Please confirm you have checked survey pictures !"
    Exit Sub
End If


answer = MsgBox("This will update the survey record with any changes made" & vbNewLine & "Status will change to Validated" & vbNewLine & "Are you sure ?", vbYesNo + vbQuestion, "Update Survey")

If answer = vbYes Then
'update current row in excel db
'chech whether text or value
SurveyStatusTxt17.Text = "ValidatedRicoh"
ValidateTxt0 = Sheets("Final").Cells(currentrow, C_SURVEYNUMBER)
ValidateTxt1 = Sheets("Final").Cells(currentrow, C_AddrLineOne)
ValidateTxt2 = Sheets("Final").Cells(currentrow, C_AddrLineTwo)
ValidateTxt3 = Sheets("Final").Cells(currentrow, C_City)
ValidateTxt4 = Sheets("Final").Cells(currentrow, C_Region)
ValidateTxt5 = Sheets("Final").Cells(currentrow, C_District)
ValidateTxt6 = Sheets("Final").Cells(currentrow, C_Postcode)
ValidateTxt7 = Sheets("Final").Cells(currentrow, C_CtyCode)
ValidateTxt8 = Sheets("Final").Cells(currentrow, C_Timezone)
ValidateTxt9 = Sheets("Final").Cells(currentrow, C_Lat)
ValidateTxt10 = Sheets("Final").Cells(currentrow, C_Long)
ValidateTxt11 = Sheets("Final").Cells(currentrow, C_UploadSpd)
ValidateTxt12 = Sheets("Final").Cells(currentrow, C_LockerAccess)
ValidateTxt13 = Sheets("Final").Cells(currentrow, C_DelInfo)
ValidateTxt14 = Sheets("Final").Cells(currentrow, C_Parking)
ValidateTxt15 = Sheets("Final").Cells(currentrow, C_KioskDirections)
ValidateTxt16 = Sheets("Final").Cells(currentrow, C_DownloadSpd)
SurveyStatusTxt17 = Sheets("Final").Cells(currentrow, C_SurveyStatus)
F_PDFLink = Sheets("Final").Cells(currentrow, C_PDFLink)

'Set Status to ValidatedRicoh
Sheets("Final").Cells(currentrow, C_Validation) = "ValidatedRicoh"

'Add row to TEMPLATE - ONB FILE tab
'HERE

Application.ScreenUpdating = False

    Sheets("Final").Select
    'Sheets("Final").Calculate
    Range(Cells(currentrow, 1), Cells(currentrow, C_Validation)).Select
   
    'HERE
   
    Sheets("TEMPLATE - ONB FILE").Select
    Range("B2").Select
    Selection.End(xlDown).Select
    Lastrow = ActiveCell.Row + 1
   
    'loop through each field and past relevant data into the TEMPLATE - ONB FILE table at the bottom
    Sheets("Final").Select
    Row_Final = ActiveCell.Row
   
    C = 0
    Field_Row = (Row_Final * -1) + 1


   
    Do Until IsEmpty(ActiveCell.Offset(Field_Row, 0))
        On Error GoTo Errorhandler1
        Application.Calculation = xlManual
        'calculation manual and put it to automatic after
       
        Column_Aligned = ActiveCell.Column
        Field_Row = (Row_Final * -1) + 1
        Field_Name = ActiveCell.Offset(Field_Row, 0)
        'ActiveCell.Offset(Row_Final, c).Select
        Range(Cells(Row_Final, Column_Aligned), Cells(Row_Final, Column_Aligned)).Select
        ActiveCell.Copy
        Sheets("TEMPLATE - ONB FILE").Select
        Range("1:1").Select
        ActiveSheet.Cells.Find(Field_Name, LookAt:=xlWhole).Select
        Column_TEMPLATE_ONB_FILE = ActiveCell.Column
        Range(Cells(Lastrow, Column_TEMPLATE_ONB_FILE), Cells(Lastrow, Column_TEMPLATE_ONB_FILE)).Select
        Selection.PasteSpecial xlPasteValues
        Selection.PasteSpecial xlPasteFormats

Errorhandler1:
        Resume Continue1
Continue1:
        Sheets("Final").Select
        ActiveCell.Offset(0, 1).Select
       
       
    Loop
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True

    'Range("A2:DM2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("TEMPLATE - ONB FILE").Select
    'check last row
    Range("B1").Select
    If IsEmpty(Range("B2")) Then
        ActiveCell.Offset(1, 0).Select
        Else
        Selection.End(xlDown).Select
        ActiveCell.Offset(1, 0).Select
    End If
    ActiveCell.Offset(0, -1).Select
    ActiveSheet.Paste
    'paste the new status into column b
    Range("B" & (ActiveCell.Row - 1)).Select
    ActiveCell.Value = Sheets("Final").Cells(currentrow, C_Validation)
    Sheets("Control Page").Select

NextBtn_Click
SurveyPhotosChkBox.Value = False
End If

End Sub

Private Sub SurveyLinkBtn_Click()
'open survey from excel
Dim surveylink As String
Dim myClipbd As New DataObject
Dim answer As String


surveylink = Sheets("Final").Cells(currentrow, 117)
MsgBox surveylink
answer = MsgBox("Link saved please open a browser window and paste link to check photos", vbOKOnly, "Validate photos")


With myClipbd
        .SetText surveylink  'Me.TextBox1.Text
        .PutInClipboard
    End With

End Sub



'load userfrom with data
Private Sub UserForm_Initialize()
Dim statuscheck As String

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

currentrow = 2
a = 1
'only load new records
statuscheck = Sheets("Final").Cells(currentrow, 2)
Do While statuscheck <> "New / Pending Validation"
currentrow = currentrow + 1
statuscheck = Sheets("Final").Cells(currentrow, 2)
a = a + 1
If a > 107 Then End
Loop
SurveyPhotosChkBox.Value = False
ValidateTxt0 = Sheets("Final").Cells(currentrow, C_SURVEYNUMBER)
ValidateTxt1 = Sheets("Final").Cells(currentrow, C_AddrLineOne)
ValidateTxt2 = Sheets("Final").Cells(currentrow, C_AddrLineTwo)
ValidateTxt3 = Sheets("Final").Cells(currentrow, C_City)
ValidateTxt4 = Sheets("Final").Cells(currentrow, C_Region)
ValidateTxt5 = Sheets("Final").Cells(currentrow, C_District)
ValidateTxt6 = Sheets("Final").Cells(currentrow, C_Postcode)
ValidateTxt7 = Sheets("Final").Cells(currentrow, C_CtyCode)
ValidateTxt8 = Sheets("Final").Cells(currentrow, C_Timezone)
ValidateTxt9 = Sheets("Final").Cells(currentrow, C_Lat)
ValidateTxt10 = Sheets("Final").Cells(currentrow, C_Long)
ValidateTxt11 = Sheets("Final").Cells(currentrow, C_UploadSpd)
ValidateTxt12 = Sheets("Final").Cells(currentrow, C_LockerAccess)
ValidateTxt13 = Sheets("Final").Cells(currentrow, C_DelInfo)
ValidateTxt14 = Sheets("Final").Cells(currentrow, C_Parking)
ValidateTxt15 = Sheets("Final").Cells(currentrow, C_KioskDirections)
ValidateTxt16 = Sheets("Final").Cells(currentrow, C_DownloadSpd)
SurveyStatusTxt17 = Sheets("Final").Cells(currentrow, C_SurveyStatus)
F_PDFLink = Sheets("Final").Cells(currentrow, C_PDFLink)

'Application.Calculation = xlCalculationManual

End Sub

4th One sends email, but I want this to stay as it is under the button, so I wouldn't want to change it.

Can someone kindly let me know how can I do step by step for the 1st 3 buttons to be consolidated to this one button?

Thank you in advance.
 

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.
Sort by date Sort by votes
.
VBA Code: 
Sub RunThreeMacros()

    Load_Survey_Data1

    Reformat_JotForm_Extract

    TheThirdMacroName

End Sub
 
Upvote 0
Hey Logit,

It crashed my file and didn't work.

I did it for two macros only as the third one needs amending to exclude the form and clicking.

Thank you for the try though.
 
Upvote 0
.
There is something wrong with your macros then ....
 
Upvote 0
Hey, would you be able to test my codes and let me know what is wrong? if I would create a dummy data?
 
Upvote 0
.
I'll review but can't guarantee anything.

Create your sample workbook and post it on a Cloud Site for download. Post the link.
 
Upvote 0
Hi Logit,

Thank you for your code, I repaired my codes and it works perfectly! That was really helpful.

I have got issue with the Validation code. What I want it to do, is to copy filtered by "New / Pending Validation" data that is in "Final" sheet and paste only matching headers to "SurveyDB" sheet in the same workbook. What I have got so far is not working properly, could you kindly review my code and let me know how can I amend it to get it work the way I need? Thank you in advance.

VBA Code: 
Private Sub Validation ()
'Move rows from fINAL worksheet that contain the word "New / Pending Validation" - column B
Worksheets("Final").Activate
With ActiveSheet
.AutoFilterMode = False
If Application.CountIf(.Range("B:B"), "*New / Pending Validation*") > 0 Then
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*New / Pending Validation*"
        .Offset(1).SpecialCells(12).EntireRow.copy
    End With
Else
    Beep
    MsgBox "New not found", vbInformation, "NO MATCH"
    Exit Sub
End If
'Go to SurveyDB worksheet and paste records in first available row
Worksheets("SurveyDB").Activate
Range("A1048576").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Interior.Color = xlNone
Range("A1").Select
'Release copy mode from Final worksheet
Worksheets("Final").Activate
Application.CutCopyMode = False
' Undo Macro
    Sheets("Final").Select
    ActiveSheet.Range("$B$1:$B$958").AutoFilter Field:=1
End With
End Sub
 
Upvote 0
.
Your code copies in the IF / END IF at the beginning of the macro but it doesn't paste anything until after leaving the IF / END IF.

In essence what your code is doing is copying but then disregarding what it has copied.

Most everything after the END IF should be in the upper portion of your macro IF / ELSE.
 
Upvote 0
Hi Logit,

Thanks for that. The code worked either way. What I want it to do is not to just simply paste it to the other sheet like it does now, I want it to identify the same headers and paste to the correct headers. Do you know how to tweak the code to not just paste, but to paste into the matching headers?

VBA Code: 
Private Sub Validation()
'Move rows from fINAL worksheet that contain the word "New / Pending Validation" - column B
Worksheets("Final").Activate
With ActiveSheet
.AutoFilterMode = False
If Application.CountIf(.Range("B:B"), "*New / Pending Validation*") > 0 Then
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .AutoFilter 1, "*New / Pending Validation*"
        .Offset(1).SpecialCells(12).EntireRow.copy
    End With
    'Go to SurveyDB worksheet and paste records in first available row
Worksheets("SurveyDB").Activate
Range("A1048576").Select
Selection.End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.Interior.Color = xlNone
Range("A1").Select
'Release copy mode from Final worksheet
Worksheets("Final").Activate
Application.CutCopyMode = False
' Undo Macro
    Sheets("Final").Select
    ActiveSheet.Range("$B$1:$B$958").AutoFilter Field:=1
Else
    Beep
    MsgBox "New not found", vbInformation, "NO MATCH"
    Exit Sub
End If
End With
End Sub
 
Upvote 0
.
I misunderstood your question.

If you can post your workbook for download and review. You'll need to use a Cloud website like DropBox.com or similar.
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,224,733
Messages
6,180,627
Members
452,991
Latest member
JM_000888

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top