Fill Button

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

The code in itself is OK, so I assume that either OldText or NewText isn't correct...
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »

Old Text:

Code: Select all

Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()"
New Text:

Code: Select all

Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()"

    ' Re-color the buttons
    With Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT3&4").Shapes("Rounded Rectangle 2").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT5&6").Shapes("Rounded Rectangle 7").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
End Sub

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

How did you put that into the code? I need specific information if you want me to help you!
By the way, you should not include End Sub in NewText.
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »

I have this code.

Code: Select all

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Sheets("CHIT5&6").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6
    Sheets("CHIT3&4").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6
    Sheets("CHIT1&2").Range("E24,K8,J9,J12,E28,E29").Interior.ColorIndex = 6

    Sheets("CHIT1&2").Range("E21").Value = Sheets("CHIT1&2").Range("E20").Value
    Sheets("CHIT1&2").Range("E22").Value = 0

    Sheets("CHIT1&2").Range("H21").Value = Sheets("CHIT1&2").Range("H20").Value
    Sheets("CHIT1&2").Range("H22").Value = 0

    Sheets("CHIT5&6").Range("E21").Value = Sheets("CHIT5&6").Range("E20").Value
    Sheets("CHIT5&6").Range("E22").Value = 0

    Sheets("CHIT5&6").Range("H21").Value = Sheets("CHIT5&6").Range("H20").Value
    Sheets("CHIT5&6").Range("H22").Value = 0

    Sheets("CHIT3&4").Range("E21").Value = Sheets("CHIT3&4").Range("E20").Value
    Sheets("CHIT3&4").Range("E22").Value = 0

    Sheets("CHIT3&4").Range("H21").Value = Sheets("CHIT3&4").Range("H20").Value
    Sheets("CHIT3&4").Range("H22").Value = 0

    Sheets("CHIT1&2").Range("B24").Formula = "=NOW()-TODAY()"
    Sheets("CHIT3&4").Range("B24").Formula = "=NOW()-TODAY()"
    Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()"
and I want to add this to it.

Code: Select all

' Re-color the buttons
    With Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT3&4").Shapes("Rounded Rectangle 2").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT5&6").Shapes("Rounded Rectangle 7").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

Yes, I understand. But how did you define OldText and NewText in your code?
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »

I tried this:

Code: Select all

Sub ReplaceText()
    Const OldText = " Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()""
    Const NewText = " Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()"
'    Re-color the buttons
    With Sheets("CHIT1&2").Shapes("Rounded Rectangle 3").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT3&4").Shapes("Rounded Rectangle 2").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With
    With Sheets("CHIT5&6").Shapes("Rounded Rectangle 7").Fill
        .Visible = True
        .ForeColor.RGB = RGB(176, 245, 254)
    End With"
    Dim Folder As String
    Dim File As String
    Dim Wbk As Workbook
    Dim NumLines As Long
    Dim Lines As String
    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            Folder = .SelectedItems(1)
        Else
            MsgBox "You didn't select a folder!", vbExclamation
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Folder = Folder & "\"
    File = Dir(Folder & "*.xlsm")
    Do While File <> ""
        If UCase(File) <> UCase(ThisWorkbook.Name) Then
            Set Wbk = Workbooks.Open(Folder & File)
            With Wbk.VBProject.VBComponents("ThisWorkbook").CodeModule
                NumLines = .CountOfLines
                Lines = .Lines(1, NumLines)
                Lines = Replace(Lines, OldText, NewText)
                .DeleteLines 1, NumLines
                .AddFromString Lines
            End With
            Wbk.Close SaveChanges:=True
        End If
        File = Dir
    Loop
    Application.ScreenUpdating = True
   
End Sub

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

That won't work, obviously. You have to double " within a quoted string, and you must use concatenation with vbCrLf to create a multi-line string.

Code: Select all

Sub ReplaceText()
    Dim OldText As String
    Dim NewText As String
    Dim Folder As String
    Dim File As String
    Dim Wbk As Workbook
    Dim NumLines As Long
    Dim Lines As String

    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            Folder = .SelectedItems(1)
        Else
            MsgBox "You didn't select a folder!", vbExclamation
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False

    OldText = "    Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()"""

    NewText = "    Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()""" & vbCrLf & _
        "'    Re-color the buttons" & vbCrLf & _
        "    With Sheets(""CHIT1&2"").Shapes(""Rounded Rectangle 3"").Fill" & vbCrLf & _
        "        .Visible = True" & vbCrLf & _
        "        .ForeColor.RGB = RGB(176, 245, 254)" & vbCrLf & _
        "    End With" & vbCrLf & _
        "    With Sheets(""CHIT3&4"").Shapes(""Rounded Rectangle 2"").Fill" & vbCrLf & _
        "        .Visible = True" & vbCrLf & _
        "        .ForeColor.RGB = RGB(176, 245, 254)" & vbCrLf & _
        "    End With" & vbCrLf & _
        "    With Sheets(""CHIT5&6"").Shapes(""Rounded Rectangle 7"").Fill" & vbCrLf & _
        "        .Visible = True" & vbCrLf & _
        "        .ForeColor.RGB = RGB(176, 245, 254)" & vbCrLf & _
        "    End With"

    Folder = Folder & "\"
    File = Dir(Folder & "*.xlsm")
    Do While File <> ""
        If UCase(File) <> UCase(ThisWorkbook.Name) Then
            Set Wbk = Workbooks.Open(Folder & File)
            With Wbk.VBProject.VBComponents("ThisWorkbook").CodeModule
                NumLines = .CountOfLines
                Lines = .Lines(1, NumLines)
                Lines = Replace(Lines, OldText, NewText)
                .DeleteLines 1, NumLines
                .AddFromString Lines
            End With
            Wbk.Close SaveChanges:=True
        End If
        File = Dir
    Loop

    Application.ScreenUpdating = True
End Sub
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »

It is not replacing, everything remained the same in ThisWorkbook.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

It worked for me...
Does it work if you change

Code: Select all

    OldText = "    Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()"""
to

Code: Select all

OldText = "    Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()"""
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »

I tried it. No it didn't work.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

I'd have to see the workbook...
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »


User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Fill Button

Post by HansV »

This version works for me on your workbook 1.xlsm; I haven't tested the rest.

Code: Select all

Sub ReplaceText()
    Dim OldText As String
    Dim NewText As String
    Dim Folder As String
    Dim File As String
    Dim Wbk As Workbook
    Dim NumLines As Long
    Dim Lines As String

    With Application.FileDialog(4) ' msoFileDialogFolderPicker
        If .Show Then
            Folder = .SelectedItems(1)
        Else
            MsgBox "You didn't select a folder!", vbExclamation
            Exit Sub
        End If
    End With

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    OldText = "Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()"""

    NewText = "    Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()""" & vbCrLf & _
        "'    Re-color the buttons" & vbCrLf & _
        "    With Sheets(""CHIT1&2"").Shapes(""Rounded Rectangle 3"").Fill" & vbCrLf & _
        "        .Visible = True" & vbCrLf & _
        "        .ForeColor.RGB = RGB(176, 245, 254)" & vbCrLf & _
        "    End With" & vbCrLf & _
        "    With Sheets(""CHIT3&4"").Shapes(""Rounded Rectangle 2"").Fill" & vbCrLf & _
        "        .Visible = True" & vbCrLf & _
        "        .ForeColor.RGB = RGB(176, 245, 254)" & vbCrLf & _
        "    End With" & vbCrLf & _
        "    With Sheets(""CHIT5&6"").Shapes(""Rounded Rectangle 7"").Fill" & vbCrLf & _
        "        .Visible = True" & vbCrLf & _
        "        .ForeColor.RGB = RGB(176, 245, 254)" & vbCrLf & _
        "    End With"

    Folder = Folder & "\"
    File = Dir(Folder & "*.xlsm")
    Do While File <> ""
        If UCase(File) <> UCase(ThisWorkbook.Name) Then
            Set Wbk = Workbooks.Open(Filename:=Folder & File, UpdateLinks:=False)
            With Wbk.VBProject.VBComponents("ThisWorkbook").CodeModule
                NumLines = .CountOfLines
                Lines = .Lines(1, NumLines)
                Lines = Replace(Lines, OldText, NewText)
                .DeleteLines 1, NumLines
                .AddFromString Lines
            End With
            Wbk.Close SaveChanges:=True
        End If
        File = Dir
    Loop

    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Best wishes,
Hans

Bomba
3StarLounger
Posts: 281
Joined: 20 Jan 2019, 19:43

Re: Fill Button

Post by Bomba »

I tried it and looks that it works fine.
Thanks a lot and sorry for disturbing you.