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.
 
Sort by date Sort by votes

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
What I understand ... there are several Columns of data on the SurveyDB sheet that should not be copied/pasted to the Final sheet.

Method #1:

If nothing more will be done with the data after pasting to FINAL sheet ... you could copy the entire rows from SURVEYDB sheet and paste to FINAL sheet, then hide
the columns you are not wanting to view.


Method #2:

If after pasting the data to FINAL sheet something more will be done with the data that requires the unwanted Columns to not exist, you could first copy/paste
the data to a temporary sheet. Delete the columns of data that are unwanted ... then copy the data from the temporary sheet to the FINAL sheet.
 
Upvote 0
Hi, none of the methods mentioned by you are suitable. I know it can be done by the code as I almost reused one that did things I explained, just couldn’t get it to be pasted below the data in SurveyDB. Thank you for your help and I will continue to try to resolve it on my own.
 
Upvote 0
You must log in or register to reply here.

Similar threads

SandsB
  • Question
Why does "Step Into" stop after I open my input file?
Replies
4
Views
284
SandsB
SandsB
L
  • Solved
Is there a way to generalize my repeated VBA code into one macro that I could apply to ALL buttons?
Replies
5
Views
488
DanteAmor
DanteAmor
A
  • Question
Import Table Data from Web using VBA to excel Worksheet and able to input Values which can modify the web data to be extract
Replies
0
Views
358
Ambrosia
A
G
  • Solved
Data Import stopping after 16 rows
Replies
2
Views
343
grabrail
G
C
  • Question
Replacing PowerPoint Input using Find and Replace Arrays from Excel through VBA
Replies
0
Views
1K
ckcs
C

Forum statistics

Threads
1,215,028
Messages
6,122,749
Members
449,094
Latest member
dsharae57

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