Solved

How to Auto-fill data in Database

Posted on 2016-11-19
2
19 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 17

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

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Hide vba in gp 7 49
Access MDB/PDF 21 32
Determine 90 days from most recent date 3 26
Excel VBA problem Error 1004 2 6
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
Workbook link problems after copying tabs to a new workbook? David Miller (dlmille) Intro Have you either copied sheets to a new workbook, and after having saved and opened that workbook, you find that there are links back to the original sou…
The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

744 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

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now