Update cell after update from userform

[Patriot2879]

HI i hope you can help me with the code below as this is not working an i am trying to update a cell in a sheet called 'Data' if changes are made in my userform, my range in the 'Data' sheet my range is A1:R17 , ROWS B1:R1 have dates inand columns A2:A17 have areas in, then B2:R17 have numbers in.

In ComboBox1 and ComboBox2 this is a lookupfor the date and area where it cross references and find the number in thecorresponding cell and put this number into TextBox53. In TextBox54 this iswhere the number can be updated. What i want is then this to update the correspondingcell from A1:R17.



- ComboBox1 contains adate matching one of the dates in B1:R1 and

- ComboBox2 contains an area matching one of the areas in A2:A17 and
- TextBox54 is entered manually


Hope you can help with the code please?

[FONT=Calibri]Option Explicit[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]Private Sub Worksheet_Change(ByVal Target As Range)[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  Dim a() As Variant,i As Long, j As Long[/FONT]


[FONT=Calibri]  Dim sThisFullName AsString, sSynchronized As String[/FONT]


[FONT=Calibri]  Dim Wb As Workbook,IsOpen As Boolean[/FONT]


[FONT=Calibri]  Dim FullName AsVariant, FullNames As Range[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  If Target.Address<> "TextBox54" Or Target.Value = "" Then Exit Sub[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Determine Row [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=and]#and[/URL]  Column #[/FONT]


[FONT=Calibri]  i = Application.Match(Range("ComboBox2"),Range("A1:A17"), 0)[/FONT]


[FONT=Calibri]  If i = 0 Then MsgBoxRange("ComboBox1") & " not found in A1:A18",vbCritical: Exit Sub[/FONT]


[FONT=Calibri]  j =Application.Match(Range("ComboBox1"), Range("A1:R18"), 0)[/FONT]


[FONT=Calibri]  If i = 0 Then[/FONT]


[FONT=Calibri]    MsgBoxRange("ComboBox2").Value & " not found in A1:A17",vbCritical[/FONT]


[FONT=Calibri]    Exit Sub[/FONT]


[FONT=Calibri]  ElseIf j = 0 Then[/FONT]


[FONT=Calibri]    MsgBoxRange("ComboBox1").Value & " not found in A1:R1",vbCritical[/FONT]


[FONT=Calibri]    Exit Sub[/FONT]


[FONT=Calibri]  End If[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Disable eventshandling, enable auto calculation[/FONT]


[FONT=Calibri] Application.EnableEvents = False[/FONT]


[FONT=Calibri] Application.Calculation = xlCalculationAutomatic[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Adjust theIntersection cell Value by substracting Input in TextBox54[/FONT]


[FONT=Calibri]  Cells(i, j).Value =Cells(i, j).Value - Target.Value[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Clear ONLY Targetcell and select it[/FONT]


[FONT=Calibri]  Target.ClearContents[/FONT]


[FONT=Calibri]  Target.Select[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Disable blinking[/FONT]


[FONT=Calibri] Application.ScreenUpdating = False[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  i =UBound(FullNames.Value) - 1[/FONT]


[FONT=Calibri]  j = 0[/FONT]


[FONT=Calibri]  sThisFullName =LCase(ThisWorkbook.FullName)[/FONT]


[FONT=Calibri]  a() =Me("Data").Range("A1").CurrentRegion.Value[/FONT]


[FONT=Calibri]  For Each FullName InFullNames.Value[/FONT]


[FONT=Calibri]    If InStr(FullName,"") > 0 And LCase(FullName) <> sThisFullName Then[/FONT]


[FONT=Calibri]      j = j + 1[/FONT]


[FONT=Calibri]     Application.StatusBar = "Updating (" & j &"/" & i & "): " & FullName[/FONT]


[FONT=Calibri]      On Error ResumeNext[/FONT]


[FONT=Calibri]      Set Wb =Workbooks(Mid(FullName, InStrRev(FullName, "") + 1))[/FONT]


[FONT=Calibri]      IsOpen = (Err =0)[/FONT]


[FONT=Calibri]      On Error GoToexit_[/FONT]


[FONT=Calibri]      If Not IsOpenThen[/FONT]


[FONT=Calibri]        Set Wb =Workbooks.Open(FullName, UpdateLinks:=False)[/FONT]


[FONT=Calibri]      End If[/FONT]


[FONT=Calibri]      With Wb[/FONT]


[FONT=Calibri]       .Sheets("Data")(Me.Name).Range("A1").CurrentRegion.Resize(UBound(a),UBound(a, 2)).Value = a()[/FONT]


[FONT=Calibri]        .Save[/FONT]


[FONT=Calibri]        If Not IsOpenThen .Close False[/FONT]


[FONT=Calibri]      End With[/FONT]


[FONT=Calibri]      sSynchronized =sSynchronized & IIf(j > 1, vbLf, "") & FullName[/FONT]


[FONT=Calibri]    End If[/FONT]


[FONT=Calibri]  Next[/FONT]


[FONT=Calibri] ThisWorkbook.Activate[/FONT]


[FONT=Calibri]  [/FONT]


[FONT=Calibri]exit_:[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Restore eventshandling, screen updating and status bar[/FONT]


[FONT=Calibri] Application.EnableEvents = True[/FONT]


[FONT=Calibri] Application.ScreenUpdating = True[/FONT]


[FONT=Calibri] Application.StatusBar = False[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]  ' Inform about error[/FONT]


[FONT=Calibri]  If Err Then[/FONT]


[FONT=Calibri]    MsgBoxErr.Description, vbCritical, "Error!"[/FONT]


[FONT=Calibri]  Else[/FONT]


[FONT=Calibri]    ' Put updatinginfo in the comment of TextBox54[/FONT]


[FONT=Calibri]    If Target.CommentIs Nothing Then Target.AddComment[/FONT]


[FONT=Calibri]    WithTarget.Comment[/FONT]


[FONT=Calibri]      .Visible = True[/FONT]


[FONT=Calibri]      .TextText:="[Updated " & j & " workbook(s) on " &Now & "]" & vbLf & sSynchronized[/FONT]


[FONT=Calibri]      .Shape.TextFrame.AutoSize= True[/FONT]


[FONT=Calibri]     .Shape.TextFrame.AutoSize = False[/FONT]


[FONT=Calibri]    End With[/FONT]


[FONT=Calibri]  End If[/FONT]


[FONT=Calibri] [/FONT]


[FONT=Calibri]End Sub[/FONT]

 

[dmt32]

this is brill thank you, its amazing, I can put all the textboxes into one? wow that would be amazing as it is massive at the moment

Ok will do this in couple of steps

Follow all instructions CAREFULLY

1 - Make a BACKUP

2 - From the VB Editor Insert > Class Module

3 - Name the new module TextBoxClass <<< This is very important


Insert the following code in the Class Module

Public WithEvents TextBoxClass As MSForms.TextBox


Private Sub TextBoxClass_Change()
    With TextBoxClass
    Select Case .Value
        Case 1 To 2:
            .BackColor = vbYellow
        Case 3 To 20:
            .BackColor = vbGreen
        Case 0:
            .BackColor = vbRed
        Case Else:
            .BackColor = vbWhite
    End Select
    End With
End Sub

Ensure you copy ALL the codes as published.


Save the workbook & let me know - will then provide updated code for userform

Dave

 

[Patriot2879]

Hi I did that but it hasn't done anything I deleted one of the colour codes for a textbox but it stayed white, I followed the process above, apart from what did you mean copy ALL the codes as published?

 

[dmt32]

Hi I did that but it hasn't done anything I deleted one of the colour codes for a textbox but it stayed white, I followed the process above, apart from what did you mean copy ALL the codes as published?

Without wishing to sound rude, really need to read all that I am posting

Save the workbook & let me know - will then provide updated code for userform

apart from what did you mean copy ALL the codes as published?

Exactly that - did you copy ALL the code I posted to the Class Module?

If so, confirm & I will provide the updated userform code for next step

Dave

 

[Patriot2879]

Hi Dave I got it too work deleted the coding as described now all working

 

[dmt32]

Hi Dave I got it too work deleted the coding as described now all working

Have you inserted the Class Module & added the code in way I described in #post 21?

Dave

 

[Patriot2879]

Hi Dave, yes I have done that

 

[dmt32]

Hi Dave, yes I have done that

follow carefully

1 - BackUP your workbook

2 - DELETE ALL THE CODE in your userforms code page

3 - Place all following code in your userforms code page

Dim TextBox() As New TextBoxClass
Dim wRow As Long, wCol As Long
Dim wsData As Worksheet


Private Sub TextBox54_Change()
    Dim Availability As Integer, Book As Integer
    
    If Not Me.Visible Or Len(Me.TextBox54) = 0 Then Exit Sub
    
    Availability = Val(Me.TextBox53.Value)
    Book = Val(Me.TextBox54.Value)
    
    If Availability > 0 Then
        If Book > 0 And Book <= Availability Then
            Availability = Availability - Book
            wsData.Cells(wRow, wCol).Value = Availability
            Me.TextBox53.Text = Availability


'un comment this line if you want to clear textbox
'after enter
            'Me.TextBox54.Text = ""


            RefreshTable
        End If
    End If
End Sub


Sub RefreshTable()
    Dim r As Long, c As Long
    Dim txtbox As Integer
    r = 2
    c = 2
    For txtbox = 34 To 122
     Select Case txtbox
     Case 51 To 54
     
     Case Else
        Me.Controls("TextBox" & txtbox).Text = wsData.Cells(r, c).Text
        c = c + 1
        If c > 18 Then c = 2: r = r + 1
     End Select
        
    Next txtbox
End Sub


Sub find_date_area()
  If ComboBox1.ListIndex = -1 Then Exit Sub
  If ComboBox2.ListIndex = -1 Then Exit Sub
  wRow = ComboBox2.ListIndex + 2
  wCol = ComboBox1.ListIndex + 2
  TextBox53 = wsData.Cells(wRow, wCol).Text
End Sub


Private Sub ComboBox1_Change()
  Call find_date_area
End Sub


Private Sub ComboBox2_Change()
  Call find_date_area
End Sub


Private Sub CommandButton3_Click()
    Dim aOutlook As Object
    Dim aEmail As Object
    Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
    Set aOutlook = CreateObject("Outlook.Application")
    Set aEmail = aOutlook.CreateItem(0)
        With aEmail
            .htmlBody = "Hi There," & _
            "MPAN / MPRN: " & _
            "Post Code: " & _
            "Comments:  " & _
            "Job Type: " & _
            "Many thanks "
            .To = Worksheets("Email Links").Range("A2").Value
            .CC = ""
            .BCC = ""
            .Subject = "AMR - 2 Man Request"
            .Display
        End With
End Sub


Private Sub UserForm_Initialize()
    Dim DateStr As String, ResultStr As String
    Dim c As Long
    Dim i As Integer, txtbox As Integer
    Dim Count As Integer
    
    Set wsData = ThisWorkbook.Worksheets("Data")
    
    c = 2
    
    For txtbox = 1 To 18
        If txtbox <> 12 Then
            DateStr = wsData.Cells(1, c).Text
            ResultStr = Right(DateStr, 1)
        For i = Len(DateStr) - 1 To 1 Step -1
            ResultStr = ResultStr & vbCrLf & Mid(DateStr, i, 1)
        Next i
        With Me.Controls("TextBox" & txtbox)
            .MultiLine = vbTrue
            .Text = ResultStr
        End With
            c = c + 1
        End If
        ResultStr = ""
    Next txtbox
    
'build class for textbox change event
    For txtbox = 34 To 122
        Select Case txtbox
            Case 51, 52, 54
                    
            Case Else
                Count = Count + 1
                ReDim Preserve TextBox(1 To Count)
                Set TextBox(Count).TextBoxClass = Me.Controls("TextBox" & txtbox)
        End Select
    Next txtbox
                         
    RefreshTable
                    
    ComboBox1.RowSource = ""
    ComboBox2.RowSource = ""
                    
    With wsData
        ComboBox1.List = Application.Transpose(.Range("B1:R1").Value)
        ComboBox2.List = .Range("A2:R" & .Range("A" & .Rows.Count).End(xlUp).Row).Value
    End With
                    
End Sub

ENSURE that you copy ALL the code including the variables that MUST sit at the very TOP of your forms code page OUTSIDE any procedure.

Hopefully, if you followed my instructions, you should now find that the class event you added will now do the same job as those textbox change events you had.

Dave

 

[Patriot2879]

Wow that is amazing thank you, that makes the code to be so much shorter, thankyou for everything

 

[dmt32]

Wow that is amazing thank you, that makes the code to be so much shorter, thankyou for everything

Most welcome - glad it all helped


Dave

 

[Patriot2879]

just outstanding thank you