Fill Button
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Fill Button
The code in itself is OK, so I assume that either OldText or NewText isn't correct...
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
Old Text:
New Text:
Code: Select all
Sheets("CHIT5&6").Range("B24").Formula = "=NOW()-TODAY()"
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
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Fill Button
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.
By the way, you should not include End Sub in NewText.
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
I have this code.
and I want to add this to it.
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()"
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
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Fill Button
Yes, I understand. But how did you define OldText and NewText in your code?
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
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
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Fill Button
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
Hans
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
It is not replacing, everything remained the same in ThisWorkbook.
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Fill Button
It worked for me...
Does it work if you change
to
Does it work if you change
Code: Select all
OldText = " Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()"""
Code: Select all
OldText = " Sheets(""CHIT5&6"").Range(""B24"").Formula = ""=NOW()-TODAY()"""
Best wishes,
Hans
Hans
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
I tried it. No it didn't work.
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
You have the link.
https://www.dropbox.com/sh/dhjmslv2adol ... c3RDa?dl=0
https://www.dropbox.com/sh/dhjmslv2adol ... c3RDa?dl=0
-
- Administrator
- Posts: 78487
- Joined: 16 Jan 2010, 00:14
- Status: Microsoft MVP
- Location: Wageningen, The Netherlands
Re: Fill Button
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
Hans
-
- 3StarLounger
- Posts: 281
- Joined: 20 Jan 2019, 19:43
Re: Fill Button
I tried it and looks that it works fine.
Thanks a lot and sorry for disturbing you.
Thanks a lot and sorry for disturbing you.