Solved

VBA Code Mixed Combining Two User Forms

Posted on 2016-11-19
7
54 Views
Last Modified: 2016-11-20
My current User form i was developed  from two earlier versions over a few weeks which were both working (of a fashion), but when I combined them into one User-form  I think I may have now  different code conventions and nothing works as it did? For example, the 1st record no longer shows the details of the User form 1st record and it also seems that my command buttons no longer work and I think my 'Print Records' part of the User-form is not correct.

Any tips and advice and assistance on where I have gone wrong  would be much appreciated!
Paul

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


Combined Userform
0
Comment
Question by:Paul Clayton
  • 3
  • 2
  • 2
7 Comments
 
LVL 46

Expert Comment

by:Martin Liss
ID: 41894493
Can you attach the workbook?
0
 

Author Comment

by:Paul Clayton
ID: 41894498
Forgot to mention I only want the user to be allowed to input data in columns D & E. Column A updates OK with the Next No. but I need Columns B & C to auto 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.
Column F & G are also displaying as decimal instead of percentages in the Userform.
00-Test_User_Form-18Nov.xlsm
0
 
LVL 46

Expert Comment

by:Martin Liss
ID: 41894500
I'm going out with the wife to a play so I'll take a look at this tomorrow unless someone else beats me to it.
0
Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41894570
This code looks like some that I have already helped you with, but you have ignored comments that I made, e.g.

'/// if you use a With Statement then the control needs prefixing with .

You have stopped formatting the TextBoxes
by adding the apostrophe in fromnt of the lin


    '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")

Open in new window


I've mad some amendments. Part of which is adding a Procedure to format the TwextBoxes when they are completeed. A TextBox will not retain it's formatting like a cell.

What is the word part for. I need to have a separate look at that.
00-Test_User_Form-18Nov--1-.xlsm
0
 
LVL 17

Accepted Solution

by:
Roy_Cox earned 500 total points
ID: 41894580
This one fixes the next, Previous, etc buttons.

Try the word procedure to see if that works now as well.

The code could be greatly streamloned but I have only time to make it work at the moment.
00-Test_User_Form-18Nov--1-.xlsm
0
 

Author Closing Comment

by:Paul Clayton
ID: 41894627
Combined solution with another query
0
 
LVL 17

Expert Comment

by:Roy_Cox
ID: 41894700
Pleased to help. My next solution is much better
0

Featured Post

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

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…
Some code to ensure data integrity when using macros within Excel. Also included code that helps secure your data within an Excel workbook.
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 …
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

920 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

14 Experts available now in Live!

Get 1:1 Help Now