Any time I enable the macro below, the worksheet corrupts.
I have copied and pasted my data into a brand new book.
Upon saving and re-opening, I receive the "Do you want to attempt to recover as much as we can?" dialog, and the formatting on the macro-enabled sheet is reset, and the macro disabled.
I see this in the VBA editor, which appears like "Sheet 2" is being treated as some unknown object, and gives "First Article" another sheet variable.
Can anyone help?
Private Sub Worksheet_Activate()
Dim vars As Variant
vars = Array("<CLICK FOR VARIANT LIST>", "sensitive content hidden")
Dim sVars As String
sVars = Join(vars, ",")
With Range("E6").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=sVars
End With
vars = Array("NOT SET", "SET")
sVars = Join(vars, ",")
With Range("I6").Validation
.Delete
.Add Type:=xlValidateList, Formula1:=sVars
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vars As Variant
vars = Array("<CLICK FOR VARIANT LIST>", "sensitive content hidden")
If Target.Address = Range("E6").Address Then
Dim i As Integer
i = Application.Match(Range("E6").Value, vars, False)
If i = 1 Then
Range("A11:A109").EntireRow.Hidden = True
Range("D111:D112").EntireRow.Hidden = False
Else
Range("A11:A109").EntireRow.Hidden = False
Range("D111:D112").EntireRow.Hidden = True
Range("A1").Value = i + 6
End If
'SXM/HD
If i = 0 _
Or Range("E6").Value = "sensitive content hidden" Then
Range("hd_sw_row").EntireRow.Hidden = False
Range("hd_pn_row").EntireRow.Hidden = False
Range("sxm_pn_row").EntireRow.Hidden = False
Range("sxm_function_row").EntireRow.Hidden = False
Else
Range("hd_sw_row").EntireRow.Hidden = True
Range("hd_pn_row").EntireRow.Hidden = True
Range("sxm_pn_row").EntireRow.Hidden = True
Range("sxm_function_row").EntireRow.Hidden = True
End If
'DAB
If i = 0 _
Or Range("E6").Value = "sensitive content hidden"
Then
Range("dab_sw_row").EntireRow.Hidden = False
Range("dab_pn_row").EntireRow.Hidden = False
Range("dab_function_row").EntireRow.Hidden = False
Else
Range("dab_sw_row").EntireRow.Hidden = True
Range("dab_pn_row").EntireRow.Hidden = True
Range("dab_function_row").EntireRow.Hidden = True
End If
'GPS
If i = 0 _
Or Range("E6").Value = "sensitive content hidden"
Then
Range("gps_sw_row").EntireRow.Hidden = False
Range("gps_pn_row").EntireRow.Hidden = False
Range("gps_function_row").EntireRow.Hidden = False
Else
Range("gps_sw_row").EntireRow.Hidden = True
Range("gps_pn_row").EntireRow.Hidden = True
Range("gps_function_row").EntireRow.Hidden = True
End If
End If
End Sub
Related
I created an entry form that transposes data into a table.
I would like to check that all required cells are filled out before allowing the user to save the data.
I tried using a Range("A2:E2") but it didn't seem to work, so I entered every cell that I want to check.
I am having an issue where my IsEmpty = True Or _ statement seems to never be satisfied. Even if I enter data into every cell I am checking, the MsgBox is displayed, and the Else command is skipped.
After the Else is my Macro for saving the data in the table.
Any help appreciated. Thanks.
If IsEmpty(Range("A2").Value) = True Or _
IsEmpty(Range("B3").Value) = True Or _
IsEmpty(Range("C3").Value) = True Or _
IsEmpty(Range("D3").Value) = True Or _
IsEmpty(Range("E3").Value) = True Or _
IsEmpty(Range("C5").Value) = True Or IsEmpty(Range("C6").Value) = True Or IsEmpty(Range("C7").Value) = True Or IsEmpty(Range("C8").Value) = True Or IsEmpty(Range("C9").Value) = True Or IsEmpty(Range("C10").Value) = True Or IsEmpty(Range("C11").Value) = True Or _
IsEmpty(Range("E5").Value) = True Or IsEmpty(Range("E6").Value) = True Or IsEmpty(Range("E7").Value) = True Or IsEmpty(Range("E8").Value) = True Or IsEmpty(Range("E9").Value) = True Or IsEmpty(Range("E10").Value) = True Or IsEmpty(Range("E11").Value) = True Or _
IsEmpty(Range("G5").Value) = True Or IsEmpty(Range("G6").Value) = True Or IsEmpty(Range("G7").Value) = True Or IsEmpty(Range("G8").Value) = True Or IsEmpty(Range("G9").Value) = True Or IsEmpty(Range("G10").Value) = True Or IsEmpty(Range("G11").Value) = True Or _
IsEmpty(Range("H5").Value) = True Or IsEmpty(Range("H6").Value) = True Or IsEmpty(Range("H7").Value) = True Or IsEmpty(Range("H8").Value) = True Or IsEmpty(Range("H9").Value) = True Or IsEmpty(Range("H10").Value) = True Or IsEmpty(Range("H11").Value) = True Or _
IsEmpty(Range("I5").Value) = True Or IsEmpty(Range("I6").Value) = True Or IsEmpty(Range("I7").Value) = True Or IsEmpty(Range("I8").Value) = True Or IsEmpty(Range("I9").Value) = True Or IsEmpty(Range("I10").Value) = True Or IsEmpty(Range("I11").Value) = True Or _
IsEmpty(Range("J5").Value) = True Or IsEmpty(Range("J6").Value) = True Or IsEmpty(Range("J7").Value) = True Or IsEmpty(Range("J8").Value) = True Or IsEmpty(Range("J9").Value) = True Or IsEmpty(Range("J10").Value) = True Or IsEmpty(Range("J11").Value) = True Or _
IsEmpty(Range("K5").Value) = True Or IsEmpty(Range("K6").Value) = True Or IsEmpty(Range("K7").Value) = True Or IsEmpty(Range("K8").Value) = True Or IsEmpty(Range("K9").Value) = True Or IsEmpty(Range("K10").Value) = True Or IsEmpty(Range("K11").Value) = True Or _
IsEmpty(Range("L5").Value) = True Or IsEmpty(Range("L6").Value) = True Or IsEmpty(Range("L7").Value) = True Or IsEmpty(Range("L8").Value) = True Or IsEmpty(Range("L9").Value) = True Or IsEmpty(Range("L10").Value) = True Or _
IsEmpty(Range("L11").Value) = True _
Then
MsgBox "Please fill out all required cells before saving!"
Else
'''
Count Blank Cells
Returns a message box if one of the cells in the range is empty, in the first example, or blank, in the second example. Note that the only difference between the solutions is in a different parameter for the LookIn argument of the Find method: xlFormulas (empty) vs xlValues (blank).
I abandoned the Application.CountBlank idea because it doesn't work with non-contiguous ranges.
Empty Cells
Sub FindEmpty()
Dim rgAddress As String: rgAddress = "A2,B3:E3,C5:C11,E5:E11,G5:L11"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim fCell As Range: Set fCell = ws.Range(rgAddress).Find("", , xlFormulas)
If Not fCell Is Nothing Then
MsgBox "Please fill out all required cells before saving!"
Else
' Continue to save...
End If
End Sub
Blank Cells
Sub FindBlank()
' Blank cells are:
' 1. empty cells,
' 2. cells containing the formula '=""'
' 3. cells containing a single quote (')...
Dim rgAddress As String: rgAddress = "A2,B3:E3,C5:C11,E5:E11,G5:L11"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim fCell As Range: Set fCell = ws.Range(rgAddress).Find("", , xlValues)
If Not fCell Is Nothing Then
MsgBox "Please fill out all required cells before saving!"
Else
' Continue to save...
End If
End Sub
Bonus (if someone wants to play)
Sub PopulateRange()
Const rgAddress As String = "A2,B3:E3,C5:C11,E5:E11,G5:L11"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim cell As Range
Dim n As Long
For Each cell In ws.Range(rgAddress).Cells
n = n + 1
cell.Value = n
Next cell
End Sub
I'm beginner in VBA, I would like to know if my code is efficient. I'm wondering that is to long, maybe there is some function to save the spreadsheet?
I'm proceeding like this :
I click on the button (the code runs the Userform "Edition Fichier"), the name of this Userforme in my code is uSauvegarde.
I make my choices :
The code is :
Private Sub bParcourir_Click()
With Application.FileDialog(4)
.AllowMultiSelect = False
.Show
uSauvegarde.TextBox1 = .SelectedItems(1)
End With
End Sub
Private Sub bValider_Click()
Dim wb_Saisie As Workbook, wb_Sauv As Workbook
Dim New_Wkb As String, TableDesFeuilles() As String
Dim i As Integer, NumF As Integer
Dim S As Worksheet
Dim obj As Shape
Dim mdCalc As XlCalculation
mdCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
New_Wkb = uSauvegarde.TextBox1 & "\" & uSauvegarde.TextBox2 & ".xlsx"
Set wb_Saisie = ThisWorkbook
wb_Saisie.Activate
i = 0
For Each S In wb_Saisie.Sheets
If S.Visible = True Then
ReDim Preserve TableDesFeuilles(i)
TableDesFeuilles(i) = S.Name
i = i + 1
End If
Next
Application.ScreenUpdating = False
NumF = 0
BlocageModif = True
For Each S In wb_Saisie.Sheets
If S.Visible = True Then
S.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial xlPasteValues
If NumF = 0 Then
Set wb_Sauv = ActiveWorkbook
NumF = 1
Else
ActiveSheet.Move After:=wb_Sauv.Worksheets(NumF)
NumF = NumF + 1
End If
Range("A1").Select
For i = ActiveSheet.UsedRange.Columns.Count To 1 Step -1
If ActiveSheet.Columns(i).Hidden = True Then ActiveSheet.Columns(i).Delete
Next
For j = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If ActiveSheet.Rows(j).Hidden = True Then ActiveSheet.Rows(j).Delete
Next
For Each obj In ActiveSheet.Shapes
If obj.OnAction <> "" Then obj.OnAction = ""
Next
End If
Next S
For Each NomLocal In wb_Sauv.Names
If InStr(NomLocal.Name, "Print_") = 0 Then NomLocal.Delete
Next
wb_Sauv.SaveAs Filename:= _
New_Wkb, FileFormat:= _
xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,
CreateBackup:=False
wb_Sauv.Close
Application.Calculation = mdCalc
Application.ScreenUpdating = True
MsgBox ("Fichier enregistré")
uSauvegarde.Hide
End Sub
Private Sub OptionButton1_Click()
With ThisWorkbook.Sheets("Feuil1")
uSauvegarde.TextBox2 = "Mon_fichier"
End With
End Sub
Private Sub OptionButton2_Click()
uSauvegarde.TextBox2 = ""
End Sub
Thank you for your help !
Your code looks good to me, but I found some things that didn't make any sense like a With that created more code or turning off Screen updating where it was already turned off. The code was difficult to read because of bad indentation and lack of descriptive variable names. This is really important when coding because is HIGHLY possible you will need to read it again to fix possible bugs or make it more efficient. I made some changes for you to review.
Option Explicit '---- always good to have
Private Sub bParcourir_Click()
With Application.FileDialog(4)
.AllowMultiSelect = False
.Show
uSauvegarde.TextBox1 = .SelectedItems(1)
End With
End Sub
Private Sub bValider_Click()
Dim wb_Saisie As Workbook, wb_Sauv As Workbook
Dim New_Wkb As String, TableDesFeuilles() As String
Dim i As Integer, NumF As Integer
Dim S As Worksheet
Dim obj As Shape
Dim mdCalc As XlCalculation
mdCalc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
New_Wkb = uSauvegarde.TextBox1 & "\" & uSauvegarde.TextBox2 & ".xlsx"
Set wb_Saisie = ThisWorkbook
wb_Saisie.Activate
i = 0
For Each S In wb_Saisie.Sheets
If S.Visible = True Then
ReDim Preserve TableDesFeuilles(i)
TableDesFeuilles(i) = S.Name
i = i + 1
End If
Next
'Application.ScreenUpdating = False ---- why disable "screen updating" again?
NumF = 0
BlocageModif = True
With ActiveSheet '----- a "With" here is a good idea
For Each S In wb_Saisie.Sheets
'If S.Visible = True Then
If S.Visible Then '------- the if statement above can be written like this
S.Copy
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
If NumF = 0 Then
Set wb_Sauv = ActiveWorkbook
NumF = 1
Else
.Move After:=wb_Sauv.Worksheets(NumF)
NumF = NumF + 1
End If
Range("A1").Select
For i = .UsedRange.Columns.Count To 1 Step -1
If .Columns(i).Hidden Then
t.Columns(i).Delete
End If
Next
For j = .UsedRange.Rows.Count To 1 Step -1
If .Rows(j).Hidden Then
.Rows(j).Delete
End If
Next
For Each obj In .Shapes
If obj.OnAction <> "" Then
obj.OnAction = ""
End If
Next
End If
Next S
End With
For Each NomLocal In wb_Sauv.Names
If InStr(NomLocal.Name, "Print_") = 0 Then NomLocal.Delete
Next
'------ this section of the code has problems.. check it out
wb_Sauv.SaveAs Filename:= _
New_Wkb, FileFormat:= _
xlOpenXMLWorkbook, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False,
CreateBackup:=False
wb_Sauv.Close
Application.Calculation = mdCalc
Application.ScreenUpdating = True
'MsgBox ("Fichier enregistré") '----- parenthesis are nor necessary
MsgBox "Fichier enregistré"
uSauvegarde.Hide
End Sub
Private Sub OptionButton1_Click()
'With ThisWorkbook.Sheets("Feuil1") ---- this "With" creates more code...
'uSauvegarde.TextBox2 = "Mon_fichier"
'End With
ThisWorkbook.Sheets("Feuil1").uSauvegarde.TextBox2 = "Mon_fichier"
End Sub
Private Sub OptionButton2_Click()
uSauvegarde.TextBox2 = ""
End Sub
I'm new to arrays and how to use them correctly. I keep getting MyArray(i,1) = subscript out of range and it highlights the rows, where I put in those asterisks.
I want to minimize line count and make it more efficient, so I can pull the same array into different pivot to filter.
Sub Macro1()
Dim MyArray() As Variant
Dim i As Integer
'Populate the array.
MyArray = Array("I1", "I2", "I3")
'Filter based off array values
For i = 1 To UBound(MyArray)
* ActiveSheet.PivotTables("PivotTable1").PivotFields("letters "). _
* CurrentPage = MyArray(i, 1)
Next i
End Sub
My old code that I'm trying to make more efficient is:
Sub Macro1()
Sheets("NonDomestic").PivotTables("PivotTable1").PivotFields("letters "). _
CurrentPage = "(All)"
With Sheets("NonDomestic").PivotTables("PivotTable1").PivotFields( _
"dir sales ship cust cot ")
.ClearAllFilters
.PivotItems("A1").Visible = False
.PivotItems("B1").Visible = False
.PivotItems("C1").Visible = False
.PivotItems("C2").Visible = False
.PivotItems("D1").Visible = False
.PivotItems("D2").Visible = False
.PivotItems("D3").Visible = False
.PivotItems("D4").Visible = False
.PivotItems("D5").Visible = False
.PivotItems("D6").Visible = False
.PivotItems("D7").Visible = False
.PivotItems("E1").Visible = False
.PivotItems("F1").Visible = False
.PivotItems("F2").Visible = False
.PivotItems("F3").Visible = False
.PivotItems("F4").Visible = False
.PivotItems("F5").Visible = False
.PivotItems("F6").Visible = False
.PivotItems("F7").Visible = False
.PivotItems("G1").Visible = False
.PivotItems("G2").Visible = False
.PivotItems("G3").Visible = False
.PivotItems("G4").Visible = False
.PivotItems("G5").Visible = False
.PivotItems("H1").Visible = False
.PivotItems("H3").Visible = False
.PivotItems("H4").Visible = False
'.PivotItems("I1").Visible = False
'.PivotItems("I2").Visible = False
'.PivotItems("I3").Visible = False
End With
On Error GoTo 0
CurrentPage is intended to show only 1 PivotItem of your filter.
If you have a list of visible/unvisible PivotItems, then set them individually visible, addressing them by their name or by their index.
Private Sub PivotFilterTest()
Dim pf As PivotField
Dim myArray() As Variant
Dim i As Long
myArray = Array("I1", "I2", "I3")
Set pf = ActiveSheet.PivotTables("PivotTable1").PivotFields("letters ")
With pf
.ClearManualFilter
.EnableMultiplePageItems = True
For i = LBound(myArray) To UBound(myArray)
.PivotItems(myArray(i)).Visible = False
Next i
End With
End Sub
What I'm trying to do is use a multiple checkbox form to set filter values based on a table in my "Projects" worksheet. I've been able to successfully get this working on individuals however what I need this to do is take any combination of currently 33 checkboxes to filter rows that meet all criteria selected. Below is what I currently have and it keep kicking back on the range. My range runs columns K:AQ which equal values of 11 to 43 as you'll see below.
Private Sub FilterButton_Click()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Projects")
Dim fld As Long
For fld = 11 To 43
Next
If frmSearch.CheckBox1 = True = True Or _
frmSearch.CheckBox2 = True Or frmSearch.CheckBox3 = True Or _
frmSearch.CheckBox4 = True Or frmSearch.CheckBox5 = True Or _
frmSearch.CheckBox6 = True Or frmSearch.CheckBox7 = True Or _
frmSearch.CheckBox8 = True Or frmSearch.CheckBox9 = True Or _
frmSearch.CheckBox10 = True Or frmSearch.CheckBox11 = True Or _
frmSearch.CheckBox12 = True Or frmSearch.CheckBox13 = True Or _
frmSearch.CheckBox14 = True Or frmSearch.CheckBox15 = True Or _
frmSearch.CheckBox16 = True Or frmSearch.CheckBox17 = True Or _
frmSearch.CheckBox18 = True Or frmSearch.CheckBox19 = True Or _
frmSearch.CheckBox20 = True Or frmSearch.CheckBox21 = True Or _
frmSearch.CheckBox22 = True Or frmSearch.CheckBox23 = True Or _
frmSearch.CheckBox24 = True Or frmSearch.CheckBox25 = True Or _
frmSearch.CheckBox26 = True Or frmSearch.CheckBox27 = True Or _
frmSearch.CheckBox28 = True Or frmSearch.CheckBox29 = True Or _
frmSearch.CheckBox30 = True Or frmSearch.CheckBox31 = True Or _
frmSearch.CheckBox32 = True Or frmSearch.CheckBox33 = True Then
ws.Range("K2:AQ1500").AutoFilter Field:="fld", Criteria1:="<>"
End If
End Sub
So I don't know what your UserForm looks like, but if you can, I would suggest moving these CheckBoxes to a Frame so you can loop through them much easier... like this:
Private Sub FilterButton_Click()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Projects")
Dim i As Integer
' For each child control in the frame
For i = 0 To Frame1.Controls.Count - 1
' If the child control is a check box
If TypeOf Frame1.Controls.Item(i) Is CheckBox Then
' If the CheckBox is checked
If Frame1.Controls.Item(i).Value Then
'Your code here...
Debug.Print (i & " " & Frame1.Controls.Item(i).Name)
End If
End If
Next i
End Sub
As for applying the filter, it sounds like each checkbox should be linked to a column in your range... (meaning Checkbox1 ==> 'K'?) I would do that like this: (replacing the 'your code here' from above)
' Add a filter to the column at the index of 'i' (+1 so we aren't using base 0)
ws.Range("K2:AQ1500").AutoFilter Field:=i + 1, Criteria1:="<>"
Please, if you don't understand the code, ask! I'm more than happy to explain anything. Remember that copy/paste doesn't teach! :D
Does your code not have too many "True" at the If frmSearch.CheckBox1 = True = True
part?
Try below.
Private Sub FilterButton_Click()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("Projects")
Dim fld As Long
For fld = 11 To 43
Next
If frmSearch.CheckBox1 = True Or _
frmSearch.CheckBox2 = True Or frmSearch.CheckBox3 = True Or _
frmSearch.CheckBox4 = True Or frmSearch.CheckBox5 = True Or _
frmSearch.CheckBox6 = True Or frmSearch.CheckBox7 = True Or _
frmSearch.CheckBox8 = True Or frmSearch.CheckBox9 = True Or _
frmSearch.CheckBox10 = True Or frmSearch.CheckBox11 = True Or _
frmSearch.CheckBox12 = True Or frmSearch.CheckBox13 = True Or _
frmSearch.CheckBox14 = True Or frmSearch.CheckBox15 = True Or _
frmSearch.CheckBox16 = True Or frmSearch.CheckBox17 = True Or _
frmSearch.CheckBox18 = True Or frmSearch.CheckBox19 = True Or _
frmSearch.CheckBox20 = True Or frmSearch.CheckBox21 = True Or _
frmSearch.CheckBox22 = True Or frmSearch.CheckBox23 = True Or _
frmSearch.CheckBox24 = True Or frmSearch.CheckBox25 = True Or _
frmSearch.CheckBox26 = True Or frmSearch.CheckBox27 = True Or _
frmSearch.CheckBox28 = True Or frmSearch.CheckBox29 = True Or _
frmSearch.CheckBox30 = True Or frmSearch.CheckBox31 = True Or _
frmSearch.CheckBox32 = True Or frmSearch.CheckBox33 = True Then
ws.Range("K2:AQ1500").AutoFilter Field:="fld", Criteria1:="<>"
End If
End Sub
I am trying to create a budget document in which each department only has access to their particular page - I have that part working - I am having trouble allowing an ADMIN to access all of the pages.
This is what I have as the code for my UserForm so far: (I would like "Scott" to be able to open all of the pages not just "overview")
Dim bOK2Use As Boolean
Private Sub btnOK_Click()
Dim bError As Boolean
Dim sSName As String
Dim ws As Worksheet
Dim p As DocumentProperty
Dim bSetIt As Boolean
bOK2Use = False
bError = True
If Len(txtUser.Text) > 0 And Len(txtPass.Text) > 0 Then
bError = False
Select Case txtUser.Text
Case "Scott"
sSName = "Overview"
If txtPass.Text <> "act2" Then bError = True
Case "Chris"
sSName = "Run Crew"
If txtPass.Text <> "act2" Then bError = True
Case Else
bError = True
End Select
End If
If bError Then
MsgBox "Invalid User Name or Password"
Else
'Set document property
bSetIt = False
For Each p In ActiveWorkbook.CustomDocumentProperties
If p.Name = "auth" Then
p.Value = sSName
bSetIt = True
Exit For
End If
Next p
If Not bSetIt Then
ActiveWorkbook.CustomDocumentProperties.Add _
Name:="auth", LinkToContent:=False, _
Type:=msoPropertyTypeString, Value:=sSName
End If
bOK2Use = True
Unload UserForm1
End If
End Sub
Private Sub UserForm_Terminate()
If Not bOK2Use Then
ActiveWorkbook.Close (False)
End If
End Sub
Thank you!