Code peerer needed

bartmanekul

Board Regular
Joined
Apr 3, 2017
Messages
58
Office Version
  1. 365
Platform
  1. Windows
I've been using a VBA script which was kindly made by DMT32, but I just have a query around something additional it might be able to do with a small change.

It uploads data from a line into a table, and I've noticed that you can do it from another sheet in the same book to a different table - but the source data it moves still comes from sheet1.

Is there any way to easily adjust so that it uploads the data depending on what sheet your on? It'd be great to be able to upload different data to a different table in the same book.

Code:
Sub SaveTemplateData()
'dmt32 - May 2017
    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 = "B118:BM118"
'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 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
 
Last edited:

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
This line:

Code:
Set DataEntryRange = wbTemplate.Worksheets(1).Range(TemplateInputAddress)

Forces the data to come from the first sheet in the workbook. You could try changing it to :

Code:
Set DataEntryRange = Range(TemplateInputAddress)

Which should use the data from the active sheet instead.

WBD
 
Upvote 0

Forum statistics

Threads
1,213,530
Messages
6,114,162
Members
448,554
Latest member
Gleisner2

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