Farbe ändern FormulaR1C1 auf blau?
06.04.2019 08:02:31
Werner
ich blick da nicht durch, habe es kopiert von Tino (Manfred) und in Meinen Kalender eingebaut. Ich möchte die HintergrundFarbe der Ferien von grün augf blau umstellen weiß aber nicht wie.
Schon wäre auch, wenn ich die Eingabe Jahr und Bundesland von Arbeitsblatt Stammdaten
ändern könnte. Kann mir jemand helfen?
Danke im Voraus
Gruß Werner
Hier VBA Code:
Option Explicit
Sub FerienAbfrage(sBundesland As String, sJahr As String, ArrayFerien)
Dim strAddresse As String, oQuery As QueryTable
Dim Bereich As Range, meAr, A As Long
Sheets("Ferien").UsedRange.Value = ""
sBundesland = Replace(sBundesland, "ü", "ue")
strAddresse = "http://www.ferienkalender.com/ferien_deutschland/" & sBundesland & "/" & sJahr & _
"-ferien-" & LCase(sBundesland) & ".htm"
On Error GoTo ErrorAbbfrage:
With Sheets("Ferien").QueryTables.Add(Connection:= _
"URL;" & strAddresse _
, Destination:=Sheets("Ferien").Range("$A$1"))
.Name = "Termine"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "2"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With Sheets("Ferien")
For Each oQuery In Sheets("Ferien").QueryTables
oQuery.Delete
Next oQuery
Set Bereich = .Range("B1", .Cells(.Rows.Count, 2).End(xlUp)).Offset(0, 1)
meAr = Bereich.Columns(1).Offset(0, -1)
With Application.WorksheetFunction
For A = 1 To UBound(meAr)
If InStr(meAr(A, 1), "/") > 0 And InStr(meAr(A, 1), "-") > 0 Then
meAr(A, 1) = Right$(meAr(A, 1), Len(meAr(A, 1)) - .Min(InStrRev(meAr(A, 1), "-"), _
InStrRev(meAr(A, 1), "/")))
End If
meAr(A, 1) = Replace(meAr(A, 1), " ", "")
meAr(A, 1) = Replace(meAr(A, 1), "-", " - ")
meAr(A, 1) = Replace(meAr(A, 1), "+", " - ")
meAr(A, 1) = Replace(meAr(A, 1), "/", " - ")
meAr(A, 1) = Replace(meAr(A, 1), "\", " - ")
Next A
End With
Bereich.Columns(1).Offset(0, -1) = meAr
' If Bereich.Columns(1).Offset(0, -1).Cells(1, 1) = "" Then GoTo ErrorAbbfrage
Set Bereich = .Range(Bereich, Bereich.Offset(0, 1))
Bereich.Columns(1).FormulaR1C1 = _
"=IF(LEN(RC[-1])VALUE(MID(RC[-2],FIND(""-"",RC[-2])+1,LEN(RC[-2]))&" & sJahr & "),VALUE(MID(RC[-2],FIND(""-"",RC[-2])+1,LEN(RC[-2]))&" & sJahr & "+1),VALUE(MID(RC[-2],FIND(""-"",RC[-2])+1,LEN(RC[-2]))&" & sJahr & ")))"
meAr = Bereich
For A = 1 To UBound(meAr)
If meAr(A, 1)