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
Related
So I'm working on a user form to pull data from different excel sheets and build a summary sheet based on user inputs. All of this is within one workbook without external links, and most of the solutions I have seen for this error are the result of trying to connect/open an outside source. The code works until it reaches the tenth entry, then it gives me the Object Invoked has Disconnected from its Clients error and restarts excel. I have tried commenting out the tenth entry and the same error occurs at another interval.
Private Sub Submit_Click()
If TextBox_1.Value > 0 Then
Worksheets("FirstSheet").UsedRange.Offset(3).Resize(Worksheets("FirstSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
If TextBox_2.Value > 0 Then
Worksheets("SecondSheet").UsedRange.Offset(3).Resize(Worksheets("SecondSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
If TextBox_3.Value > 0 Then
Worksheets("ThirdSheet").UsedRange.Offset(3).Resize(Worksheets("ThirdSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
...
If TextBox_9.Value > 0 Then
Worksheets("NinthSheet").UsedRange.Offset(3).Resize(Worksheets("NinthSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End If
**If TextBox_10.Value > 0 Then
Worksheets("TenthSheet").UsedRange.Offset(3).Resize(Worksheets("TenthSheet").UsedRange.Rows.Count - 3).Copy
Worksheets("Template").Rows("4").Insert shift:=xlDown
End if**
Is the issue stemming from the number of repetitions within the code? Is there a specific item within the worksheet itself that I should be looking for that would be causing this issue?
You don't need to specify each sheet separately, you can use a loop like this
Option Explicit
Private Sub Submit_Click()
Dim wb As Workbook, wsSource As Worksheet, wsTarget As Worksheet
Set wb = ThisWorkbook
Set wsTarget = wb.Sheets("Template")
Dim sheetnames As Variant
sheetnames = Array("", "FirstSheet", "SecondSheet", "ThirdSheet", "ForthSheet", _
"FifthSheet", "SixthSheet", "SeventhSheet", "EighthSheet", "NinthSheet", "TenthSheet")
Dim n As Integer, sName As String, sValue As String
Dim rngSource As Range, rngTarget As Range
Application.ScreenUpdating = False
For n = 1 To UBound(sheetnames)
sName = "TextBox_" & CStr(n)
sValue = Me.Controls(sName)
If Len(sValue) > 0 Then
' define ranges
Set wsSource = wb.Sheets(sheetnames(n))
Set rngSource = wsSource.UsedRange.Offset(3).Resize(wsSource.UsedRange.Rows.Count - 3)
Set rngTarget = wsTarget.Rows(4)
' copy to Template
rngSource.Copy
rngTarget.Insert shift:=xlDown
Application.CutCopyMode = False
End If
Next
Application.ScreenUpdating = True
MsgBox "Finished", vbInformation
End Sub
So I was able to get it running last night by splitting the code up and using variables to execute the commands. Not sure why it worked, but it worked.
Private Sub Submit_Click()
Dim Template As Range
Dim FirstSheet As Range
Set Template = Worksheets(2).Range("$A$4")
Set FirstSheet = Worksheets(3).UsedRange.Offset(3).Resize(Worksheets(3).UsedRange.Rows.Count - 3)
If TextBox_1.Value > 0 Then
FirstSheet.Copy
Template.Insert shift:=xlDown
End If
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'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
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
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!