In my worksheet, I have a table with buttons to add or erase a line below the last filled line. (It copies a range of pre-filled data and formatting from another sheet, or erases it - I don't delete the row in case it would mess with my other sheets).
When I copy the data it updates the table range, but when I erase it, it doesn't... so when I copy a new one, it skips a line.
This is the delete sub:
Sub DeleteLastLine()
'
' DeleteLastLine Macro
'
'
Sheets("Cadastro Geral").Select
Range("A" & Rows.Count).End(xlUp).EntireRow.Select 'I WOULD HAVE TO EITHER FIND A WAY TO SELECT THE LAST CELL WITH CONTENT IGNORING THE TABLE RANGE'
Selection.ClearContents
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Dim tbl As ListObject
'OR FIND A WAY TO DYNAMICALLY RESIZE THE RANGE OF MY TABLE. NOW IT GOES FROM A3:AI913... TOMORROW IT MIGHT BE AT A3:AI950
Range("A" & Rows.Count).End(xlUp).Select
End Sub
Related
I've written the code below to do a loop witch I have used in the past, I now however want to do switch the loop.
If a cell in column Q contains a 1 then it adds a row with a certain layout. The code now goes from Q3276 to Q8, how do I reverse the process Preferably I want the loop to go rom Q8 to Q LastRow. Also if anyone has a more lean way of writing the code please let me know.
Dim rngc As Range, rc As Long
Set rngc = Range("Q8:Q3276")
For rc = rngc.Count To 1 Step -1
If rngc(rc).Value = 1 Then
rngc(rc + 1).EntireRow.Insert
rngc(rc + 1).EntireRow.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A35").Select
End If
Next rc
Preferably I want the loop to go rom Q8 to Q LastRow.
To reverse a loop, you can use For rc = 1 to rngc.Count. Note that this will complicate what you are trying to do.
Also if anyone has a more lean way of writing the code please let me know.
Avoid using Select/Selection etc
Use Autofilter. This way no loops will be required and you can work with filtered rows in ONE GO
The border constants range form 5 to 12. What I mean is that the value of xlDiagonalDown is 5 and so on till xlInsideHorizontal which has a value of 12. In such a case we can use a Loop/Select Case to format the borders/cells as shown below
I have commented the code so you should not have a problem understanding it.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Dim rng As Range
Dim filteredRange As Range
Dim i As Long
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Remove any filters
.AutoFilterMode = False
'~~> Find last row in Col Q
lRow = .Range("Q" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng = .Range("Q8:Q" & lRow)
'~~> Filter the range and set your filtered range
With rng
.AutoFilter Field:=1, Criteria1:="=1"
Set filteredRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
'~~> Check if we have any filtered rows
If Not filteredRange Is Nothing Then
With filteredRange
'~~> Change interior color
With .Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
'~~> Format the borders
For i = 5 To 12
Select Case i
'~~> Left, Top, Bottom, Right
Case 7 To 10
With .Borders(i)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
'~~> DiagUp,DiagDown,InsideVert,InsideHorz
Case 5, 6, 11, 12
.Borders(i).LineStyle = xlNone
End Select
Next i
End With
End If
'~~> Remove filters
.AutoFilterMode = False
End With
End Sub
I'm trying to add thick borders on the left and right side every five columns, going all the way to the last row of the table (there are no blanks in any rows).
My code only adds the borders on the first and second rows.
I use following line twice:
Range(Selection, Selection.End(xlDown)).Select
Here's what a portion of the spreadsheet looks like. Note that the first row is a merged cell, and in the second row are table headers.
Application.DisplayAlerts = False
Dim lastCol As Integer
lastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
For i = 2 To lastCol Step 5
Range(Cells(1, i), Cells(1, i + 4)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
'Add thick borders
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select 'here's where I'm struggling
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Next i
Application.DisplayAlerts = True
The picture appears to be a list object (structured table in Excel). If so, you can work directly with the table object in VBA and avoid a ton of code writing and logic building.
Dim t as ListObject
Set t = ws.ListObjects("myTable")
Dim i as Long
For i = 1 to t.ListColumns.Count Step 5
With t.ListColumns(i).Range.Resize(t.ListRows.Count,5).Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThick
End With
'same for right border
Next
I am creating a card based database system and I want to use a button to basically be able to new cards, as seen here.
I have already created a button and assigned a macro to it, which when clicked adds a new row of these 'cards'. However, I need my macro to be dynamic whereby the new cards are always added 3 rows down from the previous row of cards. How can this be done?
Here is my code for the macro:
Range("B66:F75").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Range("B66:F75").Select
Range("F75").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("B66").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Name:"
Range("B67").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Email:"
Range("B68").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Institution:"
Range("B70").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Research Focus:"
Range("B73").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Expertise:"
Range("B75").Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Relevant Links:"
Range("B66:F75").Select
Selection.Copy
Range("H66").Select
ActiveSheet.Paste
Range("N66").Select
ActiveSheet.Paste
Range("W68").Select
I presume what needs to change is the range, to make it dynamic.
OP mentioned in comments that it can start from a blank sheet. So here is my solution.
I assume the entire spreadsheet if filled with the medium blue color so the code does not add that.
Option Explicit
Sub CreatingCards()
'Basic idea is that we will create a base row and then copy paste it "x" times.
Dim TotalRows As Long 'How many rows of cards to generate
Dim lRow As Long 'Used to keep track of the last row of text
Dim p As Long 'Used for looping
TotalRows = 4
With ActiveSheet.Range("B6:F15")
.Interior.ThemeColor = xlThemeColorAccent5
.Interior.TintAndShade = 0.799981688894314
.BorderAround Weight:=xlThin
End With
'Add Words
ActiveSheet.Range("B6").Value = "Name:"
ActiveSheet.Range("B7").Value = "Email:"
ActiveSheet.Range("B8").Value = "Institution:"
ActiveSheet.Range("B10").Value = "Research Focus:"
ActiveSheet.Range("B13").Value = "Expertise:"
ActiveSheet.Range("B15").Value = "Releveant Links:"
'Bold Headers
ActiveSheet.Range("B6").Font.Bold = True
ActiveSheet.Range("B7").Font.Bold = True
ActiveSheet.Range("B8").Font.Bold = True
ActiveSheet.Range("B10").Font.Bold = True
ActiveSheet.Range("B13").Font.Bold = True
ActiveSheet.Range("B15").Font.Bold = True
'Generate the other two cards in the row
ActiveSheet.Range("B6:F15").Copy
ActiveSheet.Range("H6").PasteSpecial xlPasteAll
ActiveSheet.Range("N6").PasteSpecial xlPasteAll
For p = 1 To TotalRows - 1 'Because we generated the first row of cards already
lRow = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
'Defines lRow as the last row with text in it.
Range("B6:R15").Copy
Range("B" & lRow + 3).PasteSpecial xlPasteAll 'Putting +3 allows for two blank rows between each card.
Next p
End Sub
I changed the color and other things of cell M1 in a worksheet. I need to do the same thing in all worksheets of my workbook (the same cell in all the sheets).
There are about 40 sheets so I need to program this task with VBA.
I recorded the procedure but don't know how to write the code to do this in all the worksheets.
The code I recorded:
Sub Macro_1() '' Macro_1 Macro ' Change the look of a cell in all worksheets '
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Font.Bold = True
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Try this for starters:
Option Explicit 'always use this, this helps avoiding typing mistakes in code
Sub MyRoutine()
'declaration of variables
Dim colIndex As Long, rowIndex As Long, ws As Worksheet
colIndex = 13 'M column
rowIndex = 1 'first row
'loop through all worksheets
For Each ws In Sheets
ws.Cells(rowIndex, colIndex).Interior.ColorIndex = 1 'put your color here
'do other stuff with the cell, like
'ws.Cells(rowIndex, colIndex).Value = "some value"
Next
End Sub
Loop each sheet of your workbook and apply the color formatting. below is the example code - sets bold property to first cell of every sheet.
For Each sh In ThisWorkbook.Sheets
'Do your format here.
sh.Range("$A$1").Font.Bold = True
Next
You can modify this for you needs:
Option Explicit
Sub allsheets()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
For Each ws In wb.Sheets
ws.Cells(1, 1).Value = "TEST"
Next
End Sub
I'm looking for an excel Macro that will set all the cell fills to no fill and make all cells have no borders. I have multiple spreadsheets in my workbook and want this to apply to all of them. I've looked all through the internet looking for something that does this, but came up short.
This should do it. Just add it to any sub and you're good to go:
Dim wsCount As Integer
Dim i As Integer
wsCount = ActiveWorkbook.Worksheets.Count
For i = 1 to wsCount
Worksheets(i).Activate
Cells.Select
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Next i