Morning -
Getting a little frustrated and need some help. Running Excel 2007 and I am trying to merge data on a second worksheet based on entries on the current worksheet I am using through a function. I tried macro recorder to get the syntax, but when I paste in to my function and make some mods to get the right variables to pass, it doesn't work.
Worksheet1: Where I am working at "Input CY11"
Worksheet2: Where I need the cells to be merged "Schedule CY11"
----
Public Function ApplyData(FindName As String, BeginDate As Date, EndDate As Date, _
Reason As String, Location As String) As String
' Fills in the calendar for the dates in question (BeginDate - EndDate)
' for the person in question (FindName) and formats the cells appropriately.
' Part 1: Setting up the data sheets
Dim InputSheet As String
Dim SkedSheet As String
Dim LookUpRng As Range
Dim NumLines As Variant
InputSheet = ActiveSheet.Name
SkedSheet = "Schedule " & Right(InputSheet, 4)
Set LookUpRng = Sheets("Data").Range("F3:G5")
NumLines = Application.VLookup(SkedSheet, LookUpRng, 2, False)
' Part 2: Setting up the rows for data application
Dim Count As Integer
Dim ApplyRow As Integer
Dim BeginCol As Integer
Dim EndCol As Integer
Dim Color As String
For Count = 1 To NumLines
If Sheets(SkedSheet).Range("B3").Offset(Count, 0).Value = FindName Then
ApplyRow = Count + 3
Exit For
End If
Next Count
For Count = 1 To 366
If Sheets(SkedSheet).Range("B2").Offset(0, Count).Value = BeginDate Then
BeginCol = Count + 2
End If
If Sheets(SkedSheet).Range("B2").Offset(0, Count).Value = EndDate Then
EndCol = Count + 2
Exit For
End If
Next Count
' Part 3: Applying the data
' 3a: Merging the date cells
Sheets(SkedSheet).Select
Range(Cells(ApplyRow, BeginCol), Cells(ApplyRow, EndCol)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sheets(InputSheet).Select
'3b: Coloring the cells
Select Case Reason
Case Is = "LV"
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696 'Color Blue
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Case Is = "SL"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419 'Color Green
.PatternTintAndShade = 0
End With
Case Is = "TVL"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419 'Color Purple
.PatternTintAndShade = 0
End With
Case Is = "OTH"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399975585192419 'Color Red
.PatternTintAndShade = 0
End With
End Select
ApplyData = "Complete"
End Function
Getting a little frustrated and need some help. Running Excel 2007 and I am trying to merge data on a second worksheet based on entries on the current worksheet I am using through a function. I tried macro recorder to get the syntax, but when I paste in to my function and make some mods to get the right variables to pass, it doesn't work.
Worksheet1: Where I am working at "Input CY11"
Worksheet2: Where I need the cells to be merged "Schedule CY11"
----
Public Function ApplyData(FindName As String, BeginDate As Date, EndDate As Date, _
Reason As String, Location As String) As String
' Fills in the calendar for the dates in question (BeginDate - EndDate)
' for the person in question (FindName) and formats the cells appropriately.
' Part 1: Setting up the data sheets
Dim InputSheet As String
Dim SkedSheet As String
Dim LookUpRng As Range
Dim NumLines As Variant
InputSheet = ActiveSheet.Name
SkedSheet = "Schedule " & Right(InputSheet, 4)
Set LookUpRng = Sheets("Data").Range("F3:G5")
NumLines = Application.VLookup(SkedSheet, LookUpRng, 2, False)
' Part 2: Setting up the rows for data application
Dim Count As Integer
Dim ApplyRow As Integer
Dim BeginCol As Integer
Dim EndCol As Integer
Dim Color As String
For Count = 1 To NumLines
If Sheets(SkedSheet).Range("B3").Offset(Count, 0).Value = FindName Then
ApplyRow = Count + 3
Exit For
End If
Next Count
For Count = 1 To 366
If Sheets(SkedSheet).Range("B2").Offset(0, Count).Value = BeginDate Then
BeginCol = Count + 2
End If
If Sheets(SkedSheet).Range("B2").Offset(0, Count).Value = EndDate Then
EndCol = Count + 2
Exit For
End If
Next Count
' Part 3: Applying the data
' 3a: Merging the date cells
Sheets(SkedSheet).Select
Range(Cells(ApplyRow, BeginCol), Cells(ApplyRow, EndCol)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sheets(InputSheet).Select
'3b: Coloring the cells
Select Case Reason
Case Is = "LV"
Application.CutCopyMode = False
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696 'Color Blue
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Case Is = "SL"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419 'Color Green
.PatternTintAndShade = 0
End With
Case Is = "TVL"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.399975585192419 'Color Purple
.PatternTintAndShade = 0
End With
Case Is = "OTH"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.399975585192419 'Color Red
.PatternTintAndShade = 0
End With
End Select
ApplyData = "Complete"
End Function
