Hi and thank you for any help with this, currently I have code that copy and pastes text from a named range then I have code that formats it however the range needs to be dynamic, I have it just set to do where my first table shows but I have over 50 tables that will be copy and pasted over:
Here is my code for the Text to be copy and pasted over:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("Auto")
Set pasteSheet = Worksheets("Final")
copySheet.Range("Range1").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Here is my code for the Formatting:
Private Sub CommandButton2_Click()
ThisWorkbook.Worksheets("Final").Range("A1:E15").Columns.AutoFit
ThisWorkbook.Worksheets("Final").Range("A3:E3").Interior.Color = RGB(180, 198, 231)
ThisWorkbook.Worksheets("Final").Range("A19:D19").Merge
ThisWorkbook.Worksheets("Final").Range("A4:A18").Merge
ThisWorkbook.Worksheets("Final").Range("A4:A17").HorizontalAlignment = -4131
ThisWorkbook.Worksheets("Final").Range("A4:A17").VerticalAlignment = -4160
ThisWorkbook.Worksheets("Final").Range("A19:D19").Interior.ColorIndex = 48
ThisWorkbook.Worksheets("Final").Range("A3:E19").Borders.LineStyle = xlContinuous
ThisWorkbook.Worksheets("Final").Range("A3:E19").Borders.Color = vbBlack
ThisWorkbook.Worksheets("Final").Range("A3:E19").Borders.Weight = xlThin
ThisWorkbook.Worksheets("Final").Range("A3:E3").Font.Bold = True
ThisWorkbook.Worksheets("Final").Range("D4:E18", "E19").Style = "Currency"
ThisWorkbook.Worksheets("Final").Range("E19").Font.Bold = True
End Sub
As you can see the code for the formatting is not dynamic but static, how would I make this dynamic, or how would I go about implementing this formatting into the text code so that it copys and pasted the text across and then formats it?
End result should look like:
Use a combination of Offset and Resize
Option Explicit
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim copySheet As Worksheet, pasteSheet As Worksheet
Dim ar, r, rng As Range
ar = Array("Range1", "Range2", "Range3")
Set copySheet = Worksheets("Auto")
Set pasteSheet = Worksheets("Final")
For Each r In ar
Set rng = pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(2, 0)
copySheet.Range(r).Copy rng
Call ApplyFormat(rng)
Next
Application.ScreenUpdating = True
End Sub
Private Sub ApplyFormat(ByVal rng As Range)
Set rng = rng.Cells(1, 1) ' top left corner
rng.Resize(15, 5).Columns.AutoFit ' A1:E15
With rng.Offset(2, 0).Resize(1, 5) ' A3:E3
.Interior.Color = RGB(180, 198, 231)
.Font.Bold = True
End With
With rng.Offset(18, 0).Resize(1, 4) ' A19:D19
.Merge
.Interior.ColorIndex = 48
End With
With rng.Offset(3, 0).Resize(15, 1) ' A4:A18
.Merge
.HorizontalAlignment = -4131
.VerticalAlignment = -4160
End With
With rng.Offset(2, 0).Resize(17, 5).Borders ' A3:E19
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
rng.Offset(3, 3).Resize(15, 2).Style = "Currency" ' D4:E18
With rng.Offset(18, 4) ' E19
.Style = "Currency"
.Font.Bold = True
End With
End Sub
Related
I have an follow-up question about this: Worksheet cell does not update after macro runs
The data validation is supose to mark the background in the cell red if it doesn't exist in the RoleList, this part works fine, when data gets entered before running the macro, but after running the macro if there still exist a fault in the grammer of the column were data validation should apply it doesn't mark the background red.
So if I have Moderatori in the RoleList before running the macro it marks the cell red, because in the RoleList it says it should be Moderator so thats ok, but if I put Moderatori in the cell and start the macro it doesn't apply the red background for the cell (should be false).
Data validation part:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const RolesList As String = "Moderator"
Const FirstCellAddress As String = "A2"
Const Delimiter As String = "||"
Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.EnableCalculation = True
Dim rng As Range
With Range(FirstCellAddress)
Set rng = Intersect(.Resize(.Worksheet.rows.Count - .Row + 1), Target)
End With
If rng Is Nothing Then
Exit Sub
End If
Application.ScreenUpdating = True
Application.EnableEvents = False
Dim cel As Range
For Each cel In rng.Cells
cel.Value = removeTrail(cel.Value, Delimiter)
Next cel
Application.EnableEvents = True
Dim Roles() As String: Roles = Split(RolesList, ",")
Dim dRng As Range
Dim aRng As Range
Dim Curr() As String
Dim cMatch As Variant
Dim n As Long
Dim isFound As Boolean
For Each cel In rng.Cells
If Not IsError(cel) Then
Curr = Split(cel.Value, Delimiter)
For n = 0 To UBound(Curr)
cMatch = Application.Match(Curr(n), Roles, 0)
If IsError(cMatch) Then
isFound = True
Exit For
Else
If StrComp(Curr(n), Roles(cMatch - 1), _
vbBinaryCompare) <> 0 Then
isFound = True
Exit For
End If
End If
Next n
If isFound Then
isFound = False
If dRng Is Nothing Then
Set dRng = cel
Else
Set dRng = Union(dRng, cel)
End If
End If
End If
Next cel
rng.Interior.Color = xlNone
If Not dRng Is Nothing Then
dRng.Interior.Color = vbRed
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
ActiveSheet.EnableCalculation = True
Worksheets(1).Columns(12).Calculate
End Sub
Function removeTrail( _
ByVal SearchString As String, _
ByVal RemoveString As String, _
Optional ByVal doTrim As Boolean = True) _
As String
If doTrim Then
removeTrail = Trim(SearchString)
Else
removeTrail = SearchString
End If
If Right(removeTrail, Len(RemoveString)) = RemoveString Then
removeTrail = Left(removeTrail, Len(removeTrail) - Len(RemoveString))
End If
End Function
Module 3:
Option Explicit
Sub RemoveFormats()
'Remove all formatting except changes in font and font size
'Turn off screen updates to improve performance
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1").Cells
'Remove cell colors
.Interior.ColorIndex = xlNone
'Remove all cell borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
'Remove all special font properties and formatting
With .Font
.FontStyle = "Regular"
.Strikethrough = False
.Superscript = False
.Subscript = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
'Restore screen updates to display changes
Application.ScreenUpdating = True
End Sub
I removed this in Module 3: .Interior.ColorIndex = xlNone it works now, this part was ofcourse removing the background color from the cells.
I changed this part to: Range("A:K").Interior.ColorIndex = 0 (So it doesn't remove the background color of the data validation happening in column L)
Option Explicit
Sub RemoveFormats()
'Remove all formatting except changes in font and font size
'Turn off screen updates to improve performance
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1").Cells
'Remove cell colors
'.Interior.ColorIndex = xlNone
Range("A:K").Interior.ColorIndex = 0
'Remove all cell borders
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
'Remove all special font properties and formatting
With .Font
.FontStyle = "Regular"
.Strikethrough = False
.Superscript = False
.Subscript = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End With
'Restore screen updates to display changes
Application.ScreenUpdating = True
End Sub
I would like to merge similar cells by columns, as of now I am using this macro
Sub MergeSimilarCells()
Set myRange = Range("A1:Z300")
CheckAgain:
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
Range(cell, cell.Offset(0, 1)).Merge
cell.VerticalAlignment = xlCenter
cell.HorizontalAlignment = xlCenter
GoTo CheckAgain
End If
Next
End Sub
My problem is with hundreds of rows and 40-50 columns, it takes forever.
I am pretty sure a For Loop could help me there but I am not skilled enough to figure it out
I know the following code is wrong but I am lost
Sub SimilarCells()
Set myRange = Range("A1:G4")
Dim count As Integer
CheckAgain:
count = 1
For Each cell In myRange
If cell.Value = cell.Offset(0, 1).Value And Not IsEmpty(cell) Then
count = count + 1
ElseIf cell.Value <> cell.Offset(0, 1).Value Then
Range(cell, cell.Offset(0, -count)).Merge
End If
Next
End Sub
Here is what I would like to accomplish
Sub MergeMe()
Dim wks As Worksheet: Set wks = Worksheets(1)
Dim myRange As Range: Set myRange = wks.Range("B2:H5")
Dim myCell As Range
Dim myCell2 As Range
Dim firstColumn As Long: firstColumn = myRange.Columns(1).column + 1
Dim lastColumn As Long: lastColumn = firstColumn + myRange.Columns.Count - 1
Dim firstRow As Long: firstRow = myRange.Rows(1).row
Dim lastRow As Long: lastRow = firstRow + myRange.Rows.Count - 1
Dim column As Long
Dim row As Long
OnStart
For column = lastColumn To firstColumn Step -1
For row = lastRow To firstRow Step -1
Set myCell = wks.Cells(row, column)
Set myCell2 = myCell.Offset(0, -1)
If myCell.Value = myCell2.Value Then
With wks.Range(myCell, myCell2)
.Merge
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
End If
Next row
Next column
OnEnd
End Sub
There are quite a few tricks in this code:
we need to get the first and last column and row;
then we should be looping from the last cell (bottom right) to the first one (top left);
we should not enter the first column, because we are using .Offset(0,-1) and we compare every cell with its leftmost one;
the reason for the whole operation, is that by default, the value of a merged cells is kept in its left top cell. The other cells of a merged cell are without a value.
This is why we always compare the merged cells with their "left" neighbour;
These are the OnEnd and OnStart, facilitating the operation.
Public Sub OnEnd()
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.AskToUpdateLinks = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
Application.StatusBar = False
End Sub
Public Sub OnStart()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.Calculation = xlAutomatic
ThisWorkbook.Date1904 = False
ActiveWindow.View = xlNormalView
End Sub
Only one merge per group
EDITED to fix - thanks Vityata for the heads-up
Sub MergeEm()
Dim rw As Range, i As Long, s As Long, v
Range("C21:J33").Copy Range("C5:J17") 'for testing purposes: replace previous run
Application.ScreenUpdating = False
For Each rw In Range("C5:J17").Rows 'or wherever
i = 1
s = 1
Do While i < (rw.Cells.Count)
v = rw.Cells(i).Value
'check for a run of same values
Do While Len(v) > 0 And v = rw.Cells(i + s).Value
s = s + 1
If i + s > rw.Cells.Count Then Exit Do
Loop
'if s>1 then had a run: merge those ells
If s > 1 Then
Application.DisplayAlerts = False
rw.Cells(i).Resize(1, s).Merge
rw.Cells(i).HorizontalAlignment = xlCenter
Application.DisplayAlerts = True
i = i + s 'skip over the merged range
s = 1 'reset s
Else
i = i + 1
End If
Loop
Next rw
End Sub
I'm pretty sure what bloats your processing time is the goto causing you to loop through everything yet again every time after every merge
Edit to take column A into account and prevent first column cells to merge with cells outside of myRange:
Sub MergeSimilarCells()
Dim i As Long
Dim myCol As String
Set myRange = Range("K1:L30")
myCol = Left(myRange.Address(True, False), InStr(myRange.Offset(0, 1).Address(True, False), "$") - 1)
If Not Intersect(myRange, Range(myCol & ":" & myCol)).Address = myRange.Address Then
Set myRange = Range(Replace(myRange.Address, Left(myRange.Address(True, False), _
InStr(myRange.Address(True, False), "$")), Left(myRange.Offset(0, 1).Address(True, False), _
InStr(myRange.Offset(0, 1).Address(True, False), "$"))))
For i = myRange.Cells.Count To 1 Step -1
If myRange.Item(i).Value = myRange.Item(i).Offset(0, -1).Value And Not IsEmpty(myRange.Item(i)) Then
Range(myRange.Item(i), myRange.Item(i).Offset(0, -1)).Merge
myRange.Item(i).VerticalAlignment = xlCenter
myRange.Item(i).HorizontalAlignment = xlCenter
End If
Next
End If
End Sub
To clarify why myRange has to start in column B: Offset(0, -1) of any cell in column A will cause an error since there is no column to the left of A.
I have a template where the user enters account information and the default range for information is range B18 to S52. This fits nicely onto the screen and is a big enough range for the details being entered 90% of the time. However on a few occasions the use may have data that is a few hundred rows. Its usally copied and pasted in but would make the sheet look messy as it would be out of the default range.
I'm trying make the formatting dynamic where by if the user enters data outside of the default range a macro is triggered that will count the rows and reformat the range.
The code I have so far from researching online is:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$18" Then
Call CountLoc
End If
End Sub
Public Sub CountLoc()
With Application
.DisplayAlerts = False
'.Calculation = xlManual
.EnableEvents = False
.ScreenUpdating = False
End With
Dim LocCount As Long
Dim WsInput As Worksheet
Dim i As Long
Dim rng As Range
Set WsInput = Sheets("Account Input")
With WsInput
LocCount = .Range("B1048576").End(xlUp).row - 17
End With
If LocCount > 35 Then
Set rng = WsInput.Range(WsInput.Cells(18, 2), WsInput.Cells(17 + LocCount, 19))
With rng
.Interior.Color = RGB(220, 230, 241)
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
End With
For i = 1 To LocCount Step 2
Rows(18 + i).EntireRow.Interior.Color = vbWhite
Next i
Else
Exit Sub
End If
This essentially colors every other row light blue and white and adds a border to each cell. The Count Loc works fine and does what I need it to do but the problem I have is that I cannot get the worksheet_Change to trigger.
Thanks in advance
there
I ran a little test using your code and the first thing I noticed, is that you set the Application.EnableEvents to False and you don't set it back on, so you are cancelling any event like the Worksheet_Change Event once that's fix the event will trigger any time the cell B18 changes, except if the value that is entered comes from a paste(not sure why) but if you use the Intersect method then it works even if the value came from a copy paste.
I did some small tweeks to your code and I think it works now. please review it and give it a try.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, ThisWorkbook.Sheets("Account Input").Range("B18")) Is Nothing Then
Call CountLoc
End If
End Sub
Public Sub CountLoc()
Dim LocCount As Long
Dim WsInput As Worksheet
Dim i As Long
Dim rng As Range
Set WsInput = Sheets("Account Input")
With WsInput
LocCount = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
If LocCount > 35 Then
Set rng = WsInput.Range(WsInput.Cells(18, 2), WsInput.Cells(LocCount, 19))
With rng
.Interior.Color = RGB(220, 230, 241)
.Borders.LineStyle = xlContinuous
.Borders.Color = vbBlack
.Borders.Weight = xlThin
End With
For i = 18 To LocCount Step 2
Set rng = WsInput.Range(WsInput.Cells(i, 2), WsInput.Cells(i, 19))
rng.Interior.Color = vbWhite
Next i
Else
Exit Sub
End If
End Sub
I am quite new to VBA, the code below is what I have managed so far but I would like to ask if someone can help with formatting and formulae copying please?
I have the below code running in my project that transfers data from a worksheet called "Update Quality Check Data" to other worksheets based on user names by 1 of 2 ways, either:
By seeing the user name of the worksheet already exists and just
copying the relevant data; or,
By creating a new worksheet with the
user name as the ws name and copying the data from the data sheet
What I would like to add would be when a new user sheet is created the format and forumlas from the first usersheet are copied into the new sheets and each additional user sheet that is created.
I have seen many threads to copy paste and the arguments between clipboard and pastespecial but now I am rather confused and not sure how to do this for sheets that do not currently exist. Could some please help me?
Public Sub transfer()
Dim ws As Worksheet, wsName As Worksheet
Dim lRow As Long, lPaste As Long
Dim sName As String
Set ws = Worksheets("Update Quality Check Data")
With ws
For lRow = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
sName = .Cells(lRow, 2)
On Error Goto NoSheettFound
Jumper:
Set wsName = Worksheets(sName)
On Error Goto 0
lPaste = wsName.Cells(Rows.Count, 3).End(xlUp).Row + 1
.Cells(lRow, 1).Copy Destination:=wsName.Cells(lPaste, 3)
.Cells(lRow, 3).Copy Destination:=wsName.Cells(lPaste, 4)
Next lRow
End With
Exit Sub
NoSheettFound:
Set wsName = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsName.Name = sName
ws.Select
Goto Jumper
End Sub
Kind Regards
John
I've done this two ways. One, create a template that's a hidden tab that I copy my format from.
Or two, you can bury EACH cell's format in your code and call it for each range you want. Example:
Sub format1(r As Range)
With r
.Interior
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.ThemeColor = xlThemeColorAccent1
.Interior.TintAndShade = 0.799981688894314
.Interior.PatternTintAndShade = 0
.Font.ThemeColor = xlThemeColorAccent2
.Font.TintAndShade = 0.399975585192419
.Font.Size = 12
.Font.Bold = True
.Font.Italic = True
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).ColorIndex = 0
.Borders(xlEdgeTop).TintAndShade = 0
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).LineStyle = xlDouble
.Borders(xlEdgeBottom).ColorIndex = 0
.Borders(xlEdgeBottom).TintAndShade = 0
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub
here's one using a template:
Sub FormatNewSheet(ws As Worksheet)
Dim wsTemplate As Worksheet
Set wsTemplate = Worksheets("Bob")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.CutCopyMode = False
'Copy the range from the template
wsTemplate.Range("D5:G10").Copy
'Paste the format to the new range
ws.Select
ws.Range("D5:G10").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.EnableEvents = True
Application.CutCopyMode = xlCopy
Application.ScreenUpdating = True
End Sub
Here is a simple test for it, passing the worksheet name to the format sub:
Sub TestFormat()
Dim ws As Worksheet
Set ws = Worksheets("my new sheet")
Call FormatNewSheet(ws)
End Sub
I hope that helps!
Last week, I found an excellent code that I've been looking for. Except that I would like to use conditional formatting vertical, not horizontal as in the original code.
The orginal code is found from: Excel VBA - How do I select a range corresponding to values in previous cells?
I tried to modify the code to suit me, but there is still something wrong and I don't know what.
There is my code:
Sub tee()
Dim startRow As Long
Dim endRow As Long
Dim i As Long
Dim j As Long
Dim ws As Excel.Worksheet
Dim entryTime As Single
Dim exitTime As Single
Dim formatRange As Excel.Range
Set ws = ActiveSheet
startRow = ws.Range("19:19").Row
endRow = ws.Range("56:56").Row
Call clearFormats
For i = 3 To ws.Cells(1, 1).End(xlToRight).Column
entryTime = ws.Cells(15, i).Value
exitTime = ws.Cells(16, i).Value
Set formatRange = Nothing
For j = startRow To endRow
If (ws.Cells(j, 2).Value > exitTime) Then
Exit For
End If
If ((entryTime < ws.Cells(j, 2).Value) And (ws.Cells(j, 2).Value < exitTime)) Then
If (formatRange Is Nothing) Then
Set formatRange = ws.Cells(j, i)
Else
Set formatRange = formatRange.Resize(, formatRange.Rows.Count + 1)
End If
End If
Next j
If (Not formatRange Is Nothing) Then
Call formatTheRange(formatRange, ws.Cells(j, "A").Value)
End If
Next i
End Sub
Private Sub clearFormats()
With ActiveSheet.Range("C19:AA56")
.clearFormats
.ClearContents
End With
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, ByRef callsign As String)
r.HorizontalAlignment = xlCenter
r.Merge
r.Value = callsign
' Apply color
With r.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight2
.Color = 3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
' Apply borders
With r.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With r.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
The last two is ordinary code. I have change only the first one.
I don't have a lot of programming with VBA, but I'm trying hard.
Jukkis
The picture tells a thousand words! Here is some code that works. I have simplified your code considerably, rather than trying to learn what you did (and why it didn't work). Feel free to compare with your original, and figure out why one works when the other didn't.
Note - I use the MATCH function to find the rows where you start/end, then format the entire column in a single step. Since I made a smaller sheet, some of the row/column numbers are different - it should be easy to see where you have to change things in the code to work for you.
Option Explicit
Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B1 in this case:
entryTimeRow = 1
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A3:
Set timeRange = Range("A3", [A3].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B1:H1) ' select all the columns you want here, but only one row
' clear previous formatting
Range("B3", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
If IsEmpty(c) Then Goto nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
Call formatTheRange(formatRange)
nextColumn:
Next c
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color
With r.Interior
.Pattern = xlSolid
.Color = 3
.TintAndShade = 0.8
End With
End Sub
Here is the result: