Color active cell based on userform answer

FFaria

New Member
Joined
Oct 20, 2022
Messages
4
Office Version
  1. 2016
  2. 2007
Platform
  1. Windows
Hi, need some, help please.
Hi have this spreadsheet with some automated VBA code someone, who I lost the trace, did to me.
It is working as I want, however, I would like to make a small upgrade, but I don't know the code and where to add it.
So, currently it works like this.
In FOLHA 1 (pic1) we have a spreadsheet where I insert some data per row that corresponds to a client process and control the payments;
For each new process I have a button in the header where it inserts a new row;
When a client pays, it can be the total in one time or several payments in diferent dates;
When a payment is made I insert the amount in the correspondent row in the columns tht has the header PAG1, PAG2 and so on until its totaly paid;
After inserting a payment in a certain column with the header PAG, I put an X right next to the amount and then I hit the Button in the header X+Print;
This action will copy the information in that row and pastes it in a receipt in FOLHA 2 (pic5);
Before it pastes the information into FOLHA 2 (pic 5) it pops up 2 userforms (pics 2, 3, 4) where I have to answer the questions;
After that it goes to FOLHA 2 (pic5) where I have a Button to print the receipt;
After click the button print it prints a page and makes a copy in PDF format to store;
Then it gest back to FOLHA 1 (pic1);
Until here it's working properly as I want.

The upgrade I would like to have is that in this process it also colors automatically the correspondent X cell of the payment with a specific color dependind on the answer in the pop up userfom "Metodo de Pagamento" (pic 4);
The possible answers and colors are in the header, Green "Numerário", Yellow "Cheque", Red "Multibanco"; Orange "Transferencia Bancária";

Currently it doesn´t color de correspondent X cell and I have to color it manualy.

So, I would be gratefull if someone can fix this for me or tell me how to do it.

Thansk in advance.
 

Attachments

  • 1.png
    1.png
    42.9 KB · Views: 10
  • 2.png
    2.png
    56 KB · Views: 11
  • 3.png
    3.png
    52.5 KB · Views: 10
  • 4.png
    4.png
    64.1 KB · Views: 11
  • 5.png
    5.png
    41.9 KB · Views: 12
  • 6.png
    6.png
    43.3 KB · Views: 13

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Maybe posting the relevant VBA code it has helps understand how it works and will be simple for you to help me with the code to color the cell automatically.


VBA Code:
Private Sub Frame1_Click()

End Sub

Private Sub Frame2_Click()

End Sub

Private Sub Label1_Click()
Dim i As Integer
r = Selection.Row
c = Selection.Column
Sheets("Folha2").Range("J10").Value = Sheets("Folha1").Cells(r, c - 1).Value
Sheets("Folha2").Range("F10").Value = Sheets("Folha1").Range("A" & r).Value
Sheets("Folha2").Range("D13").Value = Sheets("Folha1").Range("B" & r).Value
Sheets("Folha2").Range("I14").Value = Sheets("Folha1").Range("C" & r).Value
Sheets("Folha2").Range("D15").Value = Sheets("Folha1").Range("D" & r).Value
Sheets("Folha2").Range("D16").Value = Sheets("Folha1").Range("F" & r).Value
Sheets("Folha2").Range("D17").Value = Sheets("Folha1").Range("G" & r).Value
Sheets("Folha2").Range("D18").Value = Sheets("Folha1").Range("I" & r).Value
Sheets("Folha2").Range("K18").Value = Sheets("Folha1").Range("AD" & r).Value


If UserForm1.OptionButton1.Value = True Then
Sheets("Folha2").Range("D14").Value = UserForm1.OptionButton1.Caption
End If
If UserForm1.OptionButton2.Value = True Then
Sheets("Folha2").Range("D14").Value = UserForm1.OptionButton2.Caption
End If
If UserForm1.OptionButton3.Value = True Then
Sheets("Folha2").Range("D14").Value = UserForm1.OptionButton3.Caption
End If
If UserForm1.OptionButton4.Value = True Then
Sheets("Folha2").Range("D11").Value = UserForm1.OptionButton4.Caption
End If

If UserForm1.OptionButton5.Value = True Then
Sheets("Folha2").Range("D11").Value = UserForm1.OptionButton5.Caption
End If
If UserForm1.OptionButton6.Value = True Then
Sheets("Folha2").Range("D11").Value = UserForm1.OptionButton6.Caption
End If
If UserForm1.OptionButton7.Value = True Then
Sheets("Folha2").Range("D11").Value = UserForm1.OptionButton7.Caption
End If
If UserForm1.OptionButton8.Value = True Then
Sheets("Folha2").Range("D11").Value = UserForm1.OptionButton8.Caption
End If

'r = Selection.Row



Unload Me

End Sub

Private Sub Label2_Click()
Unload Me
End Sub
Sub inserting_val(val As String, rr As Integer)
If Sheets("Folha1").Range(val & rr).Value = True Then

Sheets("Folha2").Range("J10").Value = Sheets("Folha1").Range(val & rr).Offset(0, -1).Value
Sheets("Folha1").CheckBoxes.Add(0, 0, 5, 5).Select
    
    With Selection
        .Value = True
        .Display3DShading = False
        .Caption = ""
    End With
      Selection.Cut
 Sheets("Folha1").Range(val & rr).Select
 Sheets("Folha1").Paste
 Sheets("Folha1").Range("A1").Select
 
Sheets("Folha2").Range("F10").Value = Sheets("Folha1").Range("A" & rr).Value
Sheets("Folha2").Range("D13").Value = Sheets("Folha1").Range("B" & rr).Value
Sheets("Folha2").Range("I14").Value = Sheets("Folha1").Range("C" & rr).Value
Sheets("Folha2").Range("D14").Value = Sheets("Folha1").Range("D" & rr).Value
'Sheets("Folha2").Range("C10").Value = Sheets("Folha1").Range("D" & rr).Value
End If
End Sub


Private Sub optionButton1_Click()
UserForm1.Frame2.Visible = True
End Sub
Private Sub optionButton2_Click()
UserForm1.Frame2.Visible = True
End Sub
Private Sub optionButton3_Click()
UserForm1.Frame2.Visible = True
End Sub
Private Sub optionButton4_Click()
UserForm1.Label1.Visible = True
End Sub
Private Sub optionButton5_Click()
UserForm1.Label1.Visible = True
End Sub
Private Sub optionButton6_Click()
UserForm1.Label1.Visible = True
End Sub

Private Sub optionButton8_Click()
UserForm1.Label1.Visible = True
End Sub


Private Sub UserForm_Click()

End Sub
] 

[CODE=vba]
Sub d_file()
UserForm2.Show
End Sub
Sub Caixadeverificação1_Click()

Dim celluletrouvee As Range
Dim ligne As Integer
Dim col As Integer
UserForm1.Show

'e = Range("A4").End(xlDown).Row

Sheets("Folha2").Select

End Sub
Sub CreerPDF(Nomme As String, CHQ As String, MB As String, TRF As String, zoom As Integer)
Dim date_file, save_path, save_file As String
Dim x As Long

date_test = Now()
date_file = CStr(Format(date_test, "ddmmyyyy"))

'save_root = "C:\Users\admin\Desktop\upwork"
'save_root = "C:\Users\Filipe\Desktop\upwork"
save_root = "\\PAULO-PC\Drive"
'save_root = "E:\"

save_path = save_root & "\" & CHQ
save_file = save_path & "\" & date_file & "+" & TRF & "+" & MB & "€.pdf"


RŽpertoireExiste (save_root)
RŽpertoireExiste (save_path)



    
 '
  With Sheets("Folha2").PageSetup
        
        .Orientation = xlPortrait
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .zoom = zoom
       
     
    End With
    
With Sheets("Folha2")
    .ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=save_file, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False

  
End With




MsgBox "PDF generated successfully"


End Sub

Function RŽpertoireExiste(ByVal Chemin As String) As Boolean
On Error Resume Next
RŽpertoireExiste = GetAttr(Chemin) And vbDirectory
    If RŽpertoireExiste = True Then
        Exit Function
    Else
        MkDir (Chemin)
    End If
End Function


[CODE=vba]
Sub print_all()
'
' print_all Macro
'

ActiveSheet.PageSetup.PrintArea = "$A$1:$L$54"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
CreerPDF Sheets("Folha2").Range("D13").Value, Sheets("Folha2").Range("D11").Value, Sheets("Folha2").Range("J10").Value, Sheets("Folha2").Range("F10").Value, 90

Sheets("Folha1").Select

End Sub
Sub print_part()
ActiveSheet.PageSetup.PrintArea = "$A$1:$L$26"
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
        IgnorePrintAreas:=False
CreerPDF Sheets("Folha2").Range("D13").Value, Sheets("Folha2").Range("D11").Value, Sheets("Folha2").Range("J10").Value, Sheets("Folha2").Range("F10").Value, 90

Sheets("Folha1").Select
End Sub

Sub d_nome()

UserForm3.Show

End Sub


[CODE=vba]
Sub Add_row()
'
' Macro2 Macro
'

'
Application.ScreenUpdating = False

Dim nextrow As Integer
nextrow = Range("A4").End(xlDown).Row

maxfolhas = Application.WorksheetFunction.Max(Sheets("Folha1").Range("A4:A" & nextrow), Sheets("Folha3").Range("A4:A" & Sheets("Folha3").Range("A4").End(xlDown).Row))

    Range("A" & nextrow + 1).Value = maxfolhas + 1
    Sheets("Folha1").Range("A8:AH8").Select
    Selection.Copy
    Range("A" & nextrow + 1).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
  Sheets("Folha1").Range("AD8").Select
    Selection.Copy
    Range("AD" & nextrow + 1).Select
    
    ActiveSheet.Paste
    Application.CutCopyMode = False
      Sheets("Folha1").Range("AF8").Select
    Selection.Copy
    Range("AF" & nextrow + 1).Select
    
    ActiveSheet.Paste
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Sub Delete_filter()

    Selection.AutoFilter
End Sub


[CODE=vba]
Sub refresh()
'
' Macro3 Macro
'


Application.ScreenUpdating = False
y = Sheets("Folha1").Range("A7").End(xlDown).Row

For i = 7 To y
DoEvents
x = Sheets("Folha3").Range("A4").End(xlDown).Row + 1
If Sheets("Folha1").Range("AD" & i).Value = 0 And Sheets("Folha1").Range("AE" & i).Value <> 0 Then
Sheets("Folha3").Range("A" & x & ":AH" & x).Value = Sheets("Folha1").Range("A" & i & ":AH" & i).Value
Sheets("Folha3").Select
Range("A7:AH7").Select
    Selection.Copy
   Sheets("Folha3").Range("A" & x).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
Sheets("Folha1").Select
Range("AD7").Select
    Selection.Copy
   Sheets("Folha3").Select
   Range("AD" & x).Select
    
    ActiveSheet.Paste
    Application.CutCopyMode = False
      Sheets("Folha1").Select
      Range("AF7").Select
    Selection.Copy
    Sheets("Folha3").Select
    Range("AF" & x).Select
    
    ActiveSheet.Paste
    Application.CutCopyMode = False
End If

    Next i
Firstrow = 7
LastRow = y
For Lr = LastRow To Firstrow Step -1
With Sheets("Folha1").Cells(Lr, "AD")
If .Value = "0" And .Offset(0, 1) <> 0 Then .EntireRow.Delete

End With
Next Lr
x = Sheets("Folha3").Range("A4").End(xlDown).Row
ActiveWorkbook.Worksheets("Folha3").sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Folha3").sort.SortFields.Add Key:=Range("A7"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Folha3").sort
        .SetRange Range("A7:AH" & x)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Application.ScreenUpdating = False
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,230
Messages
6,170,883
Members
452,364
Latest member
springate

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top