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
Related
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
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
Summary: Find text/string based on list in another sheet and adjust trailing zeros with border around the range.
The excel workbook containing two sheet.
Sheet1 Name: List (having column A with text/string to be find and column B having numerical value) as in first image.
Sheet2 Name: "Raw" containing text anywhere and below numerical value with different decimal points. Also having few blank rows between set of range as in image 2.
I have recorded macro and tried to edit it. This macro working for Text1. Below macro find text1 in "raw" sheet and adjust the display of trailing zeros based on B1 value of list sheet.
How to loop the all listed text in column A of sheet list and adjust display of trailing zeros with outside borders. Output in image 3. Find as xlpart.
Sheet1 or list
Sheet2 or another sheet
Output
Sub Macro1()
Dim sFirstAddress As String
Dim rng As Excel.Range
With Sheets("Raw").Range("A1:DZ1000") '.UsedRange ???
'how to loop for list of text/string present in column A as in image 1.
Set C = .Find(What:="Text1", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False)
If Not C Is Nothing Then
FirstAddress = C.Address
Do
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
ActiveCell.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
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
'how to loop for number in column B for adjusting/Keeping trailing zero's
If Sheets("List").Range("B1") = 1 Then
Selection.NumberFormat = "0.0"
Else
If Sheets("List").Range("B1") = 2 Then
Selection.NumberFormat = "0.00"
Else
If Sheets("List").Range("B1") = 3 Then
Selection.NumberFormat = "0.000"
End If
End If
End If
Selection.End(xlDown).Select
Cells.FindNext(After:=ActiveCell).Activate
Set C = .FindNext(C)
If C Is Nothing Then
GoTo DoneFinding
End If
Loop While C.Address <> FirstAddress
End If
DoneFinding:
End With
End Sub
By doing trial and error continuously for 6 hours, I am able to loop both columns of list sheet and output as expected. Below code working perfectly.
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim Rng As Range
Dim I As Long
Dim item As Range
For Each item In Sheets("List").UsedRange.Columns("A").Cells
MySearch = Array(item.Value2)
If item.Value2 = "" Then
Exit Sub
Else
With Sheets("Raw").UsedRange 'Range("B1:AA10000")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), After:=.Cells(.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=True, SearchFormat:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
With Rng.Borders
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 0
.TintAndShade = 0
End With
Rng.Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
If item.Offset(, 1).Value2 = 1 Then
Selection.NumberFormat = "0.0"
Else
If item.Offset(, 1).Value2 = 2 Then
Selection.NumberFormat = "0.00"
Else
If item.Offset(, 1).Value2 = 3 Then
Selection.NumberFormat = "0.000"
Else
If item.Offset(, 1).Value2 = 4 Then
Selection.NumberFormat = "0.0000"
End If
End If
End If
End If
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End If
Next
End Sub
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