Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

VBA Code Mixed Combining Two User Forms

Posted on 2016-11-19
7
Medium Priority
?
93 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
  • 2
7 Comments
 
LVL 49

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 49

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
Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
LVL 22

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 22

Accepted Solution

by:
Roy Cox earned 2000 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 22

Expert Comment

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

Featured Post

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…

715 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