Help with VBA on new save location

[bartmanekul]

I've got a script altered from a kind soul on here, where it uploads data to a data table.

But I can't find out how to 'reset' the place it uploads to.

Where would I reset where it uploads to? On initial activation it asks for the location, but once it's given, I can't figure out how to change it.

I've copied the 3 sections of code below.

Module 1

Sub SaveTemplateData()
    Dim DatabasePassword As String, TemplateSheet As String
    Dim wbDatabase As Workbook, wbTemplate As Workbook
    Dim DatabaseRange As Range, DataEntryRange As Range, Item As Range
    Dim DatabaseName As Variant, msg As Variant, Data() As Variant
    Dim i As Integer, InputCellCount As Integer
    Dim CompleteAllCells As Boolean
    
'**********************************************************************************************
'*******************************************SETTINGS*******************************************

'Database workbook open password - enter as required (case sensitive)
    DatabasePassword = ""
'Template Input Addresses
'cells can be both contiguous & non-contiguous
    TemplateInputAddress = "B6:G6"
'data entry rules (Set True if ALL Cells must be completed)
    CompleteAllCells = False
    
'**********************************************************************************************

'Database Path / Name
    DatabaseName = Cells(Rows.Count, 1).Value

    If Len(DatabaseName) = 0 Then
        DatabaseName = BrowseFile
        If DatabaseName = False Then Exit Sub
        Cells(Rows.Count, 1).Value = DatabaseName
    End If

    On Error GoTo myerror
'check file / folder path valid
    If Not Dir(DatabaseName, vbDirectory) = vbNullString Then
        Application.ScreenUpdating = False
        Set wbTemplate = ThisWorkbook
        
'data entry range
        Set DataEntryRange = wbTemplate.Worksheets(1).Range(TemplateInputAddress)
           
'count No Input Cells
    InputCellCount = DataEntryRange.Cells.Count
    
    For Each Item In DataEntryRange.Cells
'check if required entry for all cells
        If CompleteAllCells And Len(Item.Value) = 0 Then
            MsgBox "Please Complete All Fields.", 16, "Entry Required"
            Item.Select
            Exit Sub
        End If
'build array
        i = i + 1
        ReDim Preserve Data(1 To i)
'data values to array
  If Len(Item.Text) = 10 And IsDate(Item.Text) Then
        Data(i) = DateValue(Item.Text)
    Else
        Data(i) = Item.Value
    End If
    Next Item
    
    
'or if some blank cells allowed, check if any data entered
    If Not CompleteAllCells And Application.CountA(Range(TemplateInputAddress)) = 0 Then
        MsgBox "All Fields Are Empty.", 16, "Error"
    Exit Sub
    End If
    
'Open database
        Set wbDatabase = Workbooks.Open(DatabaseName, ReadOnly:=False, Password:=DatabasePassword)
        
'Next empty range in database
        With wbDatabase.Sheets(1)
            Set DatabaseRange = .Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
        End With

'output array to database range
        DatabaseRange.Resize(1, InputCellCount).Value = Data
'close & save
        wbDatabase.Close True
'clear form
        DataEntryRange.ClearContents
'report success
        msg = Array("Template Data Saved", "Data Saved")
    Else
'report problem
        msg = Array(DatabaseName & Chr(10) & "File Not Found", "Error")
    End If
    
myerror:
    Application.ScreenUpdating = True
    If Err > 0 Then
        If Not wbDatabase Is Nothing Then wbDatabase.Close False
        MsgBox (Error(Err)), 48, "Error"
    Else
        MsgBox msg(0), 48, msg(1)
    End If
'clean up
    Set wbDatabase = Nothing
    Set wbTemplate = Nothing
    Set DataEntryRange = Nothing
End Sub

Module 2

Function BrowseFile() As Variant
    Dim sFilter As String

    sFilter = "Worksheets 2003 (*.xls),*.xls," & _
              "Worksheets 2007 > (*.xlsx),*.xlsx," & _
              "All Excel Files (*.xl*),*.xl*," & _
              "All Files (*.*),*.*"

    BrowseFile = Application.GetOpenFilename(sFilter, 2, "Select Database Workbook")
End Function

This workbook:

 Private Sub Workbook_Open()    
  If ThisWorkbook.Path = "" Then Sheets(1).Cells(Rows.Count, 1).Value = ""
End Sub

 

[John_w]

This line:

DatabaseName = Cells(Rows.Count, 1).Value

looks for the file path in the last row of column A (A1048576 for Excel 2007+), therefore delete that cell value to reset it.

 

[bartmanekul]

Thanks so much, I was looking for something far more complex!

PS didn't mean to dislike that post - can't seem to get rid of it.

 

[John_w]

LOL - it's really silly how MrExcel has gone all social media.

 

[bartmanekul]

I get thanks bit, but dunno about the likes/dislikes!

Again, much appreciated. I've just read up about the cell function so I'll put it in a better place in the document.

You stopped a rising tide of panic on my side