Мне не удалось успешно установить атрибуты шрифта при извлечении диапазона ячеек из одного листа и установке этих значений в качестве верхнего / нижнего колонтитула для всей книги.и хочу перетащить диапазон ячеек с одного листа в заголовок для всей книги, но я также хочу установить цвет шрифта и т. д. Я попытался сослаться на одну ячейку, диапазон ячеек и сослаться нафункция, но ничего не похоже на работу.Вот мой код, с комментариями, которые, надеюсь, помогут:
Sub InsertHeaderFooter()
PURPOSE: Insert Image File into Spreadsheet Header or Footer on every selected worksheet
SOURCE: www.TheSpreadsheetGuru.com/the-code-vault(Modified by FiveLetterIan)
Dim WS As Worksheet
Dim ImgPath As String
'*** Call Function for Left footer
Dim LFRange As Range
Set LFRange = Worksheets("SetupPrint").Range("B3:C3")
Dim LFRange2 As Range
Set LFRange2 = Worksheets("SetupPrint").Range("B7:C7")
Dim leftFooter As String
leftFooter = lowerleft(LFRange) & lowerleft(LFRange2)
'*** Call Function for Right Footer
Dim RFRange As Range
Set RFRange = Worksheets("SetupPrint").Range("B11:C11")
Dim rightFooter As String
rightFooter = lowerleft(RFRange)
'Image Location
ImgPath = "c:\desktop\image.jpg"
'Does the Image File Exist?
On Error Resume Next
Validation = Dir(ImgPath)
On Error GoTo 0
If Validation = "" Then
MsgBox "Could not locate image file from:" & ImgPath
Exit Sub
End If
Application.ScreenUpdating = False
For Each WS In ThisWorkbook.Worksheets
With WS.PageSetup
.LeftHeader = "LEFTHEADERTEXT"
.RightHeaderPicture.Filename = ImgPath
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
.leftFooter = leftFooter
.rightFooter = rightFooter
''''Below are other things I've tried
'.leftFooter = "™D70" & Sheet95.Range("C3").Value gets all text
'.leftFooter = "#153D70leftFooter" gets "#153D70leftFooter" in black
'.leftFooter = "™D70leftFooter" gets the text "153D70leftFooter" in black
'.leftFooter = "™D70" & leftFooter gets the text "153D70 valuefromRangeB3:C3 valuefromRangeB7:C7" in black
End With
Next WS
Set WS = Nothing
Application.ScreenUpdating = True
End Sub
'Left footer Function
Function lowerleft(ByVal LfooterRange As Range) As String
'*** Sets the range of cells on the "SetupPrint" Tab as a string for the insertheaderfooter subroutine
lowerleft = ""
If Not LfooterRange Is Nothing Then
Dim mycell As Range
For Each mycell In LfooterRange
lowerleft = lowerleft & " " & mycell.Value
Next mycell
End If
End Function
'Right footer Function
Function lowerright(ByVal RfooterRange As Range) As String
'*** Sets the range of cells on the "SetupPrint" Tab as a string for the insertheaderfooter subroutine
lowerright = ""
If Not RfooterRange Is Nothing Then
Dim mycell As Range
For Each mycell In RfooterRange
lowerright = lowerright & " " & mycell.Value
Next mycell
End If
End Function
Я продолжаю получать простой черный текст, и обычно также выводится команда VBA.