Applying same macro to a variety of ranges - excel

I have a code that does what I want it to do, but it's HUGE, as i used the macro recorder to make it. Basically, it selects a range, applies two conditional formats and goes to the next range. I can't select the whole ranges at once because the conditional format applies an AVERAGE on each range.
Here's a piece of the code:
Sub DesvPad()
Range("C3:N3").Select
Selection.FormatConditions.AddAboveAverage
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).AboveBelow = xlAboveStdDev
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 5296274
.TintAndShade = 0
End With
Selection.FormatConditions(1).NumStdDev = 1
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.AddAboveAverage
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).AboveBelow = xlBelowStdDev
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
End With
Selection.FormatConditions(1).NumStdDev = 1
Selection.FormatConditions(1).StopIfTrue = False
MsgBox "O macro foi executado até Range(C325:N325)"
End Sub
I know it's shameful, so I'll appreciate any help!

It's not really clear what your question is but I'll guess you're asking how to make your code more "modular" "
Sub Tester()
ApplyCF Range("A1:A10")
ApplyCF Range("A11:A20")
'etc
End Sub
Sub ApplyCF(rng As Range)
'here use rng instead of "Selection"
rng.FormatConditions.AddAboveAverage '<< for example
End Sub

I think this could help:
Sub formatInMySelectedSheets() 'use this just for few sheet
'that you want to change
Dim i As Worksheet
Dim Nm(1 To 3) As String
Dim s
Dim sht As Worksheet
'Imagine the book has 10 sheets, "Sheet1" to "Sheet10"
'but you only want to go to Sheet1, Sheet4 and Sheet7
Nm(1) = "Sheet1" 'this are the sheets you want to change
Nm(2) = "Sheet4"
Nm(3) = "Sheet7"
For Each i In ActiveWorkbook.Worksheets 'the workbook with the sheets...
For s = LBound(Nm) To UBound(Nm) 'from the lowest value of the array to
'to the highest
Set sht = Sheets(Nm(s))
'here the code shows the sheet to avoid some errors
'if the sheet is hidden, Show it to me!
If sht.Visible = xlSheetVeryHidden Or sht.Visible = xlSheetHidden Then
sht.Visible = xlSheetVisible
End If
'go to the sheet
sht.Activate
DesvPad 'Calls you code
Next s
Next i
End Sub
Sub formatInEverySheet() 'Use this to do it in every sheet
'no matter what!
Dim i As Worksheet
For Each i In ActiveWorkbook.Worksheets
i.Activate
' here the code shows the sheet to avoid some errors
If i.Visible = xlSheetVeryHidden Or i.Visible = xlSheetHidden Then
i.Visible = xlSheetVisible
End If
DesvPad 'Calls you code
Next i
End Sub

Related

Conditional formatting to highlight specific cells but not empty and text cells VBA

I have a macro which highlights cells outside a range. The only problem with it, is that it also highlights all empty cells and cells with text. Is there a way for it to ignore these?
Here is my code
Sub Highlight()
'
' Highlight good values
Application.ScreenUpdating = False
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
With ActiveSheet.Rows("18:79")
.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotBetween, _
Formula1:="=$C18", Formula2:="=$D18"
.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font
.Color = -16752384
.TintAndShade = 0
End With
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 13561798
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
Next ws
Application.ScreenUpdating = True
End Sub
You currently only have a row limitation to the range you are applying the conditional formatting to. If you want to limit the impacted range you just need to change your With to have both a Row and a Column limitation.
Update This:
With ActiveSheet.Rows("18:79")
To This:
With ActiveSheet.Range("A18:O79")
Edit
If each sheet has the SAME row range (18:79) but the columns have a VARYING range you just need to create a last column variable to create your dynamic range
Sub Highlight()
Dim ws As Worksheet, LC As Long
For Each ws In ActiveWorkbook.Worksheets
LC = ws.Cells(18, ws.Columns.Count).End(xlToLeft).Column
With ws.Range(ws.Cells(18, 1), ws.Cells(79, LC))
'Formatting goes here
End With
Next ws
End Sub

Unable to select range using find and offset functions

My goal is to copy rows from Sheet("VBA") to a specific location in Sheet("COLUMBIA-TAKEDOWN"). The location is Offset(1,1) of the cell containing "P R O S P E C T S". The first part of my code works well enough however my problems begin with selecting and editing a row [Prospect.Offset(13,-1).Select]. It appears to be ignoring this line of code because the formatting lines that follow are not happening. It's not throwing out an error message.
I understand that I'm incorrectly selecting the row and therefore unable to make the formatting changes but I don't know how to correct this problem.
Application.ScreenUpdating = False
Dim Prospect As Range
Set Prospect = Sheets("COLUMBIA-TAKEDOWN").Cells.Find(what:="P R O S P E C T S")
Sheets("VBA").Visible = True
Sheets("VBA").Rows("13:25").Copy
Prospect.Offset(1, -1).Insert shift:=xlDown
Prospect.Offset(13, -1).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Prospects.Offset(1, -1).Select
Sheets("VBA").Visible = False
End Sub
The problem is that you are trying to insert rows in a cell range... they are not the same size, hence the error.
Give this a try... might need some more thinkering, but i`ve just reused your code.
Sub test()
Application.ScreenUpdating = False
Dim wb As Workbook: Set wb = ThisWorkbook
Dim sht As Worksheet: Set sht = wb.Sheets("Sheet1")
Dim ProspectRow As Long: ProspectRow = sht.Cells.Find(what:="P R O S P E C T S").Row + 1
wb.Sheets("VBA").Rows("13:25").Copy
sht.Rows(ProspectRow).Insert Shift:=xlDown
With sht.Rows(ProspectRow + 13).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Application.ScreenUpdating = True
End Sub
EDIT: revamped the code for critics...
EDIT2: added the formatting...

Convert selected cells formula to value across Selected Sheets

I'm using this code below to convert formula to cells, which works fine in a single sheet. But the problem is when I need to convert all selected cells which are in different sheets to their value, this code doesn't do it.
This is how I am selecting the cells in Excel:
first I select the cells in one sheet, than I go down to the tabs right-click and select specific sheets, which in Excel selects the corresponding cells in every selected sheet.
So any tips on how I can change this code to make it work across different sheets?
Sub formulaToValues()
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each cel In Selection.Cells
cel.Value = cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
End If
End Sub
You should be able to just grab the address of the selection, then add that to each worksheet's range
Sub formulaToValues()
Dim celAddr As String
celAddr = Selection.Address
Dim ws As Worksheet
For Each ws In ActiveWindow.SelectedSheets
With ws.Range(celAddr)
.Value = .Value
.Interior.ColorIndex = 0
.Font.Color = vbBlack
End With
Next ws
End Sub
You are attempting to write to a 3D cell collection. An interesting problem i haven't seen before. I gave it a shot.
The below code works for me. I have simply added an extra loop to search through any other sheets. Note: it is good practice to always declare your variables.
Answer1: This cycles through every sheet in the workbook
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Worksheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Answer2: With this one it only goes throug the selected sheets
Sub formulaToValues()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ThisWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = 2 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub
Thanks alot guys, this got answered pretty quickly.
I am placing my macros in personal so I ended if with this
Sub formulaToValues3()
Dim cel As Range
Dim ws As Worksheet
If Selection.Cells.Count = 1 Then
Selection.Value = Selection.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Else
For Each ws In ActiveWorkbook.Windows(1).SelectedSheets
For Each cel In Selection.Cells
ws.Range(cel.Address).Value = ws.Range(cel.Address).Value 'cel.Value
Selection.Cells.Interior.ColorIndex = 0
Selection.Cells.Font.Color = vbBlack
Next cel
Next ws
End If
End Sub

Excel 2016 is asking for a password for running a VBA

I've provided a password to unprotect active sheet to perform a Macros but still, it is asking a password to perform some parts of it (1) For changing case to Uppercase and (2) for clearing contents. I don't know why? Could you help me where I am wrong! My code is -
Sub REFRESH_DATA()
Dim rng As Range
Dim last As Long
Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="****"
Set rng = Range("A8:R" & last)
last = Range("B99000").End(xlUp).Row
With rng.Borders ' Blue border
.LineStyle = xlContinuous
.Color = vbBlue
.Weight = xlThin
End With
If Range("B8") <> "" Then ''''''' Upper case''''''
ActiveSheet.Range("B8:L21000").SpecialCells(xlCellTypeConstants).Select
With Selection
.Value = UCase(.Value)
End With
End If
Range("A" & last + 1 & ":R" & 90000).ClearContents
ActiveSheet.Protect Password:="****"
End Sub
if i understood your question you have to:
1)unprotect all the sheet
example
dim ws as Worksheet
For Each ws In Worksheets
ws.Unprotect Password:=pwd
Next ws
'your code and active the sheet with the name
example
Worksheets(sheetname).Activate
and as last operation protect all sheets
For Each ws In Worksheets
ws.Protect Password:=pwd
Next ws
Hope this helps

VBA copy paste formmating and formulae

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!

Resources