Solved

How to Auto-fill data in Database

Posted on 2016-11-19
2
35 Views
Last Modified: 2016-11-20
In my Database I only want the user to be allowed to input data (from a custom Userform) in columns D & E. Column A updates OK with the Next No. but I need Columns B & C to auto fill and update with consecutive Day/Date, and auto update column F is a calculation from D & E. Auto update for column G Rate (is derived from a look up Table), and then column H Penalty (also a calculation from other data in the Workbook.

Option Explicit
Dim ws As Worksheet
Dim rData As Range
Dim CurrentRow As Long
Dim lcol As Long
Dim r As Long
Dim j As Integer


'
'Private Sub setinitialrange()
'
'    Set rData = Range("A4").CurrentRegion
'    currentrow = rData.Cells(rData.Rows.Count).End(xlUp).Row
'End Sub

Private Sub cmbAddRecord_Click()
    EditAdd
End Sub

Sub EditAdd()
    Dim emptyrow As Long, flag As Boolean, txtConDay As Long
    Dim lr As Long

    Set ws = Sheets("Sheet1")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
    If WorksheetFunction.CountIf(ws.Columns(1), Me.txtConDay) > 0 And txtConDay <> "" Then
        MsgBox "The record for this Contract Day already exists in the database." & vbNewLine & _
               "Please try again.....", vbCritical, "Contract Day Already Exists!"
        txtConDay = ""
        txtDay = ""
        txtDate = ""
        txtStd = ""
        txtAtd = ""
        txtPerf = ""
        txtRate = ""
        txtPenalty = ""

        Exit Sub
    End If

    ''///new record, if txtConDay has a value then a record exists and will be amended
    If Me.txtConDay.Value = "" Then
        Me.txtConDay.Value = Application.Max(rData.Columns(1)) + 1
        CurrentRow = rData.Rows.Count + 1
    End If
    txtConDay = Application.Max(ws.Columns(1)) + 1
    With Me
        Cells(lr, 1).Value = txtConDay.Value
        Cells(lr, 2).Value = txtDay.Value
        Cells(lr, 3).Value = txtDate.Value
        Cells(lr, 4).Value = txtStd.Value
        Cells(lr, 5).Value = txtAtd.Value
        Cells(lr, 6).Value = txtPerf.Value
        Cells(lr, 7).Value = txtRate.Value
        Cells(lr, 8).Value = txtPenalty.Value

    End With
    ClearForm

End Sub

Private Sub cmdbNextRecord_Click()
    If CurrentRow = rData.Rows.Count Then
        MsgBox "You have selected the last record", vbCritical, "Cancel"
        Exit Sub
    Else: CurrentRow = CurrentRow + 1

    End If
End Sub

Private Sub cmdbPreviousRecord_Click()
    If CurrentRow = 2 Then
        MsgBox "You have selected the first record", vbCritical, "Cancel"
        Exit Sub
    Else
        CurrentRow = CurrentRow - 1

    End If
End Sub

Sub cmdClear_Click()
    ClearForm
End Sub

Sub ClearForm()
'/// if you use a With Statement then the control needs prefixing with .
    With Me
        .txtConDay.Value = ""
        .txtDay.Value = ""
        .txtDate.Value = ""
        .txtStd.Value = ""
        .txtAtd.Value = ""
        .txtPerf.Value = ""
        .txtRate.Value = ""
        .txtPenalty.Value = ""

    End With
End Sub

Private Sub cmdFirstRecord_Click()
''///jumps to next empty row
    CurrentRow = 2
End Sub

Private Sub cmdLast_Click()
    CurrentRow = rData.Rows.Count + 1
End Sub

Private Sub cmdSearch_Click()
    Dim ws As Worksheet
    Dim lr As Long
    Set ws = Sheets("Sheet1")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row

    If txtConDay = "" Then
        MsgBox "Please input a Contract Day to search a record.", vbExclamation, "CA Contract Day Please!"
        Exit Sub
    End If

    If WorksheetFunction.CountIf(ws.Columns(1), txtConDay) = 0 Then
        MsgBox "The Contract Day you entered doesn't exist. Please try again...", vbExclamation, "Not Found!"
        Exit Sub
    End If
    r = WorksheetFunction.Match(Val(txtConDay), ws.Columns(1), 0)
    CurrentRow = r
    Me.txtDay = ws.Cells(r, "B")
    Me.txtDate = ws.Cells(r, "C")
    Me.txtStd = ws.Cells(r, "D")
    Me.txtAtd = ws.Cells(r, "E")
    Me.txtPerf = ws.Cells(r, "F")
    Me.txtRate = ws.Cells(r, "G")
    Me.txtPenalty = ws.Cells(r, "H")

End Sub

Private Sub cmdUpdate_Click()
    Dim ws As Worksheet
    Dim Ans As String
    Set ws = Sheets("Sheet1")

    If txtConDay = "" Then
        MsgBox "The Contract Day TextBox is empty, so no record can be updated in this case." & vbNewLine & _
               "Please try again.....", vbExclamation, "Not Found!"
        Exit Sub
    End If
    If WorksheetFunction.CountIf(ws.Columns(1), txtConDay) = 0 Then

        r = WorksheetFunction.Match(Val(txtConDay), ws.Columns(1), 0)


        ws.Cells(r, "B") = Me.txtDay
        ws.Cells(r, "C") = Me.txtDate
        ws.Cells(r, "D") = Me.txtStd
        ws.Cells(r, "E") = Me.txtAtd
        ws.Cells(r, "F") = Me.txtPerf
        ws.Cells(r, "G") = Me.txtRate
        ws.Cells(r, "H") = Me.txtPenalty

    End If
End Sub


Sub From_Excel_to_Word_AppendData()
'Dim wordApp As Word.Application
'Dim wordDoc As Word.Document

    Const wdStory = 6
    Const wdMove = 0
    Dim wdApp As Object
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    Set wddoc = wdApp.Documents.open("<path>")
    wdApp.Selection.WholeStory
    wdApp.Selection.Delete
    Set wddoc = "G:\Test Reports\Test_Report.docx"
    Dim wdTo As Object
    Set wdTo = wdApp.Selection
    wdTo.EndKey wdStory, wdMove
    wdTo.TypeParagraph
    Dim rng As Range
    Set rng = ("Sheet1, Table1")
    rng.Copy

    wdTo.TypeParagraph
    wdApp.Selection.PasteExcelTable False, False, False
    'commented out, changed the way it pasted the values to word.
    'wdTo.PasteSpecial Link:=False, DataType:=20, Placement:=wdInLine, DisplayAsIcon:=False

    Application.CutCopyMode = False
    wddoc.Save
    wdApp.Activate
End If
End Sub


Private Sub UserForm_Initialize()
    Dim lr As Long
    Set rData = Sheet1.Range("A3").CurrentRegion
    CurrentRow = 4
    txtConDay.SetFocus

    Set ws = Sheets("Sheet1")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    lblNextConDay = ws.Cells(lr, 1) + 1

    'txtDate.Text = Format(Now(), "Short Date")
    'txtDate.Text = Format(Now(), "Long Date")
    'txtDate.Text = Format(Now(), "dd mmm, yyyy")
    'txtDate.Text = Format(Now(), "mmmm")
    txtDate = Format(txtDate, "dd mmmm yyyy")
    'txtPerf = Format(Performance, "Percent"
    txtPerf = Format(txtPerf, "0.00%")
    'txtRte = Format(Rate, "Percent")
    txtRate = Format(txtRate, "0.00%")
    'txtPen = Format(Penalty, "Percent")
    txtPenalty = Format(txtPenalty, "#,##0.00")

End Sub
Private Sub cbRun_Click()
Dim Reports As Control

For Each Reports In UserForm1.Controls
    If UserForm1.optBut1.Value = True Then
        Application.Dialogs(xlDialogPrint).Show
    Else
    If UserForm1.optBut2.Value = True Then
    If Me.cbRun = True Then
    Me.PrintForm
Exit Sub
End If
End If
End If
Next
End Sub

Private Sub DTPicker1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
    On Error Resume Next
    Me.DTPicker1 = CDate(Me.DTPicker1)
    'Dim YourMsg As String
    If DTPicker1.Value < DateSerial(2015, 9, 12) And DTPicker2.Value > DateSerial(2034, 9, 11) Then
        If DTPicker1 = DTPicker2 Then
            msg "For Monthly Reports Select FROM the 1st day TO the last day of the required Period "
            MsgBox YourMsg, vbCancel + vbExclamation

        End If
        Debug.Print
    End Sub
Private Sub cmdQuit_Click()
    Unload UserForm1
End Sub

Open in new window


Database Screenshot
Any tips and advice and assistance on where I have gone wrong  would be much appreciated!
Paul
0
Comment
Question by:Paul Clayton
2 Comments
 
LVL 18

Accepted Solution

by:
Roy_Cox earned 500 total points
ID: 41894563
Have you got formulas in place for the calculations. If you gave convert the database to a Table then all formulas will copy down

Overview of Excel

For better help attach an example workbook.Tables


I'm not sure how this line is working

 
Set rng = ("Sheet1, Table1")

Open in new window

0
 

Author Closing Comment

by:Paul Clayton
ID: 41894626
Combined solution with another query
0

Featured Post

Live: Real-Time Solutions, Start Here

Receive instant 1:1 support from technology experts, using our real-time conversation and whiteboard interface. Your first 5 minutes are always free.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

786 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question