I would like to have a gantt style chart in my project by adding in VBA border to specific cells like here:
I tried with this script :
Public Sub DisegnaLineeGantt(ByVal riga As Long)
Dim DataInizio, DataFine As Date
Dim cell As Range
Dim ultimaColonna As Long
Dim rng As Range
Dim rng2 As Range
Set rng = Range(Cells(15, 11), Cells(15, ultimaColonna))
Set rng2 = Range(Cells(riga, 11), Cells(riga, ultimaColonna))
rng2.Borders.LineStyle = xlNone
DataInizio = Cells(riga, 3)
DataFine = Cells(riga, 4)
ultimaColonna = Worksheets("Commesse").Columns.Count
For Each cell In rng
If DataInizio = cell Then
Cells(riga, cell.Column).Borders(xlEdgeLeft).LineStyle = xlContinuous
Cells(riga, cell.Column).Borders(xlEdgeTop).LineStyle = xlContinuous
Cells(riga, cell.Column).Borders.Weight = xlMedium
ElseIf DataFine = cell Then
Cells(riga, cell.Column).Borders(xlEdgeRight).LineStyle = xlContinuous
Cells(riga, cell.Column).Borders(xlEdgeTop).LineStyle = xlContinuous
Exit For
ElseIf DataInizio < cell And DataFine > cell Then
Cells(riga, cell.Column).Borders(xlEdgeTop).LineStyle = xlContinuous
End If
Next
End Sub
Related
I have a range of data which has a combination of merged/unmerged, empty/non empty cells. I currently have the code which skips the empty cells in a given range and adds border to non-empty cells. Here is the code which I wrote.
Set iRange = ea.Range(Cells(2, 1), Cells(EAlastrow, EAlastcol))
For Each iCells In iRange
If iCells.MergeCells Then
If Not IsEmpty(iCells) Then
Dim iCellRange As String
iCellRange = iCells.MergeArea.Address
Range(iCellRange).BorderAround xlContinuous, xlThin
End If
Else
If Not IsEmpty(iCells) Then
iCells.BorderAround xlContinuous, xlThin
End If
End If
Next iCells
Is it possible to set the range in a way that it includes below empty cells too and add a border to it?
This is how the table is structured:
Thanks in advance.
Try this:
Sub SubFormat()
'Declarations.
Dim RngHeader As Range
Dim RngTarget As Range
Dim DblLastRow As Double
Dim DblMaxLastRow As Double
'Setting RngHeader as the first line of the data i want to be formatted.
Set RngHeader = Range("A2:AB2")
'Checking which is the highest value of non empty row for each column of RngHeader.
For Each RngTarget In RngHeader
DblLastRow = Cells(Cells.Rows.Count, RngTarget.Column).End(xlUp).Row
DblMaxLastRow = Excel.WorksheetFunction.Max(DblMaxLastRow, DblLastRow)
Next
'If no data has been found, the macro is terminated.
If DblMaxLastRow < RngHeader.Row Or _
(DblMaxLastRow = RngHeader.Row And Excel.WorksheetFunction.CountBlank(RngHeader) = RngHeader.Cells.Count) _
Then
MsgBox "No data found", vbCritical + vbOKOnly, "No data found"
Exit Sub
End If
'Targeting the data.
With Range(RngHeader.Cells(1, 1), Cells(DblMaxLastRow, RngHeader.Cells(1, RngHeader.Columns.Count).Column))
'Setting the borders' format.
.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Sub
You can get the last cell with data for each column and then set border for each cell in that column till the last cell with data. In below code 3 indicates column C
lastRow = Sheet2.Cells(Rows.Count, 3).End(xlUp).Row
Range("C1:C" + CStr(lastRow)).Borders.LineStyle = xlContinuous
You can try this it works fine for me:
Sub ALLBorders()
With Cells.SpecialCells(xlCellTypeConstants, 23)
.BorderAround xlContinuous, xlThin, xlColorIndexAutomatic
On Error Resume Next
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
End Sub
Here is the second requirement solution.
Sub BorderMultiRange()
With Sheets("Sheet1").Range("A28:A29,C5:E9,G11:J14")
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
End Sub
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
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:
I need to create a macro in Excel which could check if cell contents are not blank then I needed a border.
I have tried this macro:
Sub testborder()
Dim rRng As Range
Set rRng = Sheet1.Range("B2:D5")
'Clear existing
rRng.Borders.LineStyle = xlNone
'Apply new borders
rRng.BorderAround xlContinuous
rRng.Borders(xlInsideHorizontal).LineStyle = xlContinuous
rRng.Borders(xlInsideVertical).LineStyle = xlContinuous
End Sub
Try the following:
Sub testborder()
Dim rRng As Range, row As Range, c As Range
Set rRng = Sheet1.Range("B2:D5")
'Clear existing
rRng.Borders.LineStyle = xlNone
For Each row In rRng.Rows
For Each c In row.Columns
'Apply new borders
If (c.Value > "") Then c.BorderAround xlContinuous
Next c
Next row
End Sub
Or, with an even simpler loop:
For Each c In rRng.Cells
'Apply new borders
If (c.Value > "") Then c.BorderAround xlContinuous
Next c
You can do whatever test you want. In this example, it checks to see if there is any text in each cell, if so it puts a border around it.
Sub BorderForNonEmpty()
Dim myRange As Range
Set myRange = Sheet1.Range("B2:D5")
' Clear existing borders
myRange.Borders.LineStyle = xlLineStyleNone
' Test each cell and put a border around it if it has content
For Each myCell In myRange
If myCell.Text <> "" Then
myCell.BorderAround (xlContinuous)
End If
Next
End Sub
I have a very large set of data that includes start and stop times for aircraft in the NAS. I want to create a macro to make a visual representation of this data in excel, like the following:
(note: this image uses fake data)
As you can see I've done the first 7 rows by hand, but there are several data files with as many as 2500+ rows each which makes the process tedious. I've tried to create a macro but I'm confused how to search for and select the appropriate range to highlight.
Here's what I have so far:
Sub autofill()
Dim rng As Range
Dim row As Range
Dim cell As Range
'set the range of the whole search area
Set rng = Range("A2:HJ121")
For Each row In rng.Rows
Dim callsign As Variant
Set callsign = cell("contents", "A" & row)
Dim valstart As Variant
Set valstart = cell("contents", "E" & row)
Dim valstop As Variant
Set valstop = cell("contents", "F" & row)
'now select the range beginning from the column whose header matches the
'time in valstart and ends at the time which matches the time in valstop
Selection.Merge
Selection.Style = "Highlight"
Selection.Value = callsign
Next row
End Sub
What's the easiest way of selecting the rows I need?
I'm not a programmer by profession; apologies in advance if my code demonstrates sloppy technique or violates some holy programming principles. :P
Thanks!
Here's my go at VBA for this.
Option Explicit
Public Sub fillSchedule()
Dim startCol As Long
Dim endCol 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
startCol = ws.Range("H:H").Column
endCol = ws.Range("HJ:HJ").Column
Call clearFormats
For i = 2 To ws.Cells(1, 1).End(xlDown).Row
entryTime = ws.Cells(i, 5).Value
exitTime = ws.Cells(i, 6).Value
Set formatRange = Nothing
For j = startCol To endCol
If (ws.Cells(1, j).Value > exitTime) Then
Exit For
End If
If ((entryTime < ws.Cells(1, j).Value) And (ws.Cells(1, j).Value < exitTime)) Then
If (formatRange Is Nothing) Then
Set formatRange = ws.Cells(i, j)
Else
Set formatRange = formatRange.Resize(, formatRange.Columns.Count + 1)
End If
End If
Next j
If (Not formatRange Is Nothing) Then
Call formatTheRange(formatRange, ws.Cells(i, "A").Value)
End If
Next i
End Sub
Private Sub clearFormats()
With ActiveSheet.Range("H2:HJ121")
.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
.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
How about a conditional formatting solution?
Highlight all the cells from H2 to (last bottom right cell).
Use this formula:
=IF(AND((H$1>$E2),(H$1<$F2)),TRUE)
Then apply a fill. And if you're willing to give up the border and the name inside the filled range, it will work for you :).
Also, you may want to Freeze Panes from G2 so you can scroll all the way to the HJ column and still see the Callsign column.
Hope this helps