I have workbook that is shared (Office 2016) ,
I use below code to { Remove all other users from this shared Workbook }, it works, But remove only one user per run time and I have to run this code many times to remove all users (except me). should I repeat lines of code to work as supposed or modify it .
Note: although the code has if statement , in case I put End If it gives error !!
Sub Remove_Other_Users_from_Shared_Workbook()
Dim UsrList()
UsrList = ThisWorkbook.UserStatus
For i = 1 To UBound(UsrList, 1)
If Not (UsrList(i, 1) = Application.UserName) Then ThisWorkbook.RemoveUser (i)
Next
End Sub
It is usually recommended to loop array backwards when you intend to delete item from the array as each deletion will move the index of the rest of the array up by 1, which causes problem:
Sub Remove_Other_Users_from_Shared_Workbook()
Dim UsrList()
UsrList = ThisWorkbook.UserStatus
For i = UBound(UsrList, 1) To 1 Step -1
If UsrList(i, 1) <> Application.UserName Then ThisWorkbook.RemoveUser i
Next
End Sub
You are not able to add End If to your If statement because you have a line of code after Then which makes this a 1-line statement. If you do want to put End If then you must move ThisWorkbook.RemoveUser i to the next line like this:
Sub Remove_Other_Users_from_Shared_Workbook()
Dim UsrList()
UsrList = ThisWorkbook.UserStatus
For i = UBound(UsrList, 1) To 1 Step -1
If UsrList(i, 1) <> Application.UserName Then
ThisWorkbook.RemoveUser i
End If
Next
End Sub
Note: If you only have 1 line of code in the Then branch then your current code is perfectly fine.
Related
I have a VBA code that allows a user to enter in record ID numbers in a system and the code will record pertinent data to a txt file. This code was working flawlessly and one day it stopped working. An error is occurring at the Call mainLookup(GetField(rid, i, ",") portion of the code but I cannot identify and correct the error.
Sub Main()
Set System = CreateObject("XXXXX.System")
If (System Is Nothing) Then
Stop
End If
Set Session = System.ActiveSession
If (Session Is Nothing) Then
Stop
End If
Set Screen = System.ActiveSession.Screen
rid$ = InputBox("Enter RID (no dashes)" + " separate entries with a comma only")
If (Len(rid) Mod 5 <> 7) Then
MsgBox "Incorrectly formatted RID", 16, "ALAS"
End If
Number% = (Len(rid) + 1) / 6
For i = 1 To Number
Call mainLookup(GetField(rid, i, ","))
Next i
Stop
End Sub
I am getting an error as Runtime error 7 while running the cleanup names utility as mentioned in code below. I am using 512 GB HDD, 8 GB RAM, I7 processor so should not be a memory issue and still the issue pops up.
My workbook has 123188 defined names which I want to delete using the code below. Is there a way to be more efficient with the code / does someone has a code / built in addin which I can incorporate in a master addin?
The function breaks at
For Each objName In ActiveWorkbook.Names
Any help will be appreciated.
Thanks in advance
Option Explicit
Sub Cleanup_names123()
'
'Deletes all names except for Print_Area, Database, and DB
'Declare variables
Dim objName As Name
Dim strAnswer As String
'Display instructions
strAnswer = MsgBox("This function will delete all named ranges except Print_Area, DB, and Database. If you are not ready to proceed click Cancel to exit.", vbOKCancel)
'If cancelled - exit function
If strAnswer = vbCancel Then End
'If no names found, exit
If ActiveWorkbook.Names.Count = 0 Then
MsgBox "No names found. Macro complete."
End
End If
MsgBox ActiveWorkbook.Names.Count & " name(s) found. It may take a few minutes for the cleanup."
'Delete names
For Each objName In ActiveWorkbook.Names
On Error Resume Next
If InStr(objName.Name, "Database") <> 0 Then
'If Database - no action
ElseIf InStr(objName.Name, "database") <> 0 Then
'If database - no action
ElseIf InStr(objName.Name, "DB") <> 0 Then
'If database - no action
Else
objName.Delete
ThisWorkbook.Names(objName.Name).Delete
End If
Next
On Error GoTo 0
End Sub
If iterating the collection is taking up too much memory you can manually select each item one by one. When deleting items it's important to work backwards from the end because when you delete item 1 then item 2 becomes item 1. So we use Step -1 to work backwards.
To make your guard clause read plainly and avoid empty Ifs I changed the logic to If Not And. I find this more clear. Don't use underscore _ in method names because that is reserved for Event methods.
Option Explicit
Public Sub CleanupNames()
'
'Deletes all names except for Print_Area, Database, and DB
'Declare variables
Dim strAnswer As String
'Display instructions
strAnswer = MsgBox("This function will delete all named ranges except Print_Area, DB, and Database. If you are not ready to proceed click Cancel to exit.", vbOKCancel)
'If cancelled - exit function
If strAnswer = vbCancel Then Exit Sub
Dim NamesCount As Long
NamesCount = ActiveWorkbook.Names.Count
'If no names found, exit
If NamesCount = 0 Then
MsgBox "No names found. Macro complete."
Exit Sub
End If
MsgBox NamesCount & " name(s) found. It may take a few minutes for the cleanup."
'Delete names
Dim iter As Long
For iter = NamesCount To 1 Step -1
Dim objName As String
objName = ActiveWorkbook.Names.Item(iter).Name
On Error Resume Next
If Not InStr(objName, "Database") <> 0 And _
Not InStr(objName, "database") <> 0 And _
Not InStr(objName, "DB") <> 0 Then
ActiveWorkbook.Names(objName).Delete
End If
If iter Mod 5000 = 0 Then ActiveWorkbook.Save
Next iter
End Sub
UPDATE: Added the save code and changed the delete behavior.
Try this. The approach I took was to run a loop backwards from the bottom so that excel doesn't move the items up each time one is deleted and deleting via Index number rather than name. I also made the test a little more efficient I think.
Option Explicit
Sub DeleteNames()
Dim NameCount As Long
Dim Cntr As Long
Dim WkBk As Workbook
Dim TestName As String
Set WkBk = ThisWorkbook
NameCount = ActiveWorkbook.Names.Count
'Delete names
With WkBk
For Cntr = NameCount To 1 Step -1
On Error Resume Next 'not sure you need this but can't hurt
TestName = UCase(.Names(Cntr).NameLocal)
If InStr(TestName, "DATABASE") > 0 Or _
InStr(TestName, "DB") > 0 Then
'If database - no action
Else
.Names(Cntr).Delete
End If
Next Cntr
End With 'WkBk
End Sub
HTH
It may be as simple as turning off calculation and screen updates... this should increase stability and greatly increase speed.
So, before your For...Next loop -
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Then after your For...Next loop -
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
You should also consider running those last two lines after trapping any errors so that you don't leave the settings inactive.
Here is the extra bit about saving you asked for. I haven't coded up your solution as you should be able to modify this accordingly. This counts backwards from 50 and saves every 5 times through the loop with a debug statement so you can see that it works.
Sub quickSaveDemo()
Dim counter As Integer
counter = 50
For i = counter To 1 Step -1
Debug.Print "Loop count - " & i & " - Other stuff here"
If i Mod 5 = 0 Then
Debug.Print "Save here"
ActiveWorkbook.Save
End If
Next i
End Sub
So here's my objective: I need to execute different macros deppending on a multiple choice ListBox. I am a begginner with vba and some tasks get a bit harder for me at the moment.
there's a multiple choice ListBox with 9 options. If you choose the option "Exfoliación", it executes the macro called "macro4". This is fully customizable, so if I choose from the ListBox the option "Exfoliación" and "Estanqueidad", it will execute the macros 4 and 3 (the ones related to them).
I've seen some example surfinf the Internet, but they're about ListBox's working with columns, sheets, and so on. But there weren't much explanations working with macros.
The user selects the options and presses a Submit button in the worksheet called "Botón". the choices from the Listbox are marked with vector(i)=1. With a for loop the choices are read and executes the corresponding macros to those choices with the array a(i) that contains the names of those macros.
Sub Submit()
'Getting selected items in ListBox1
Dim vector(1 To 11) As Integer
Dim i As Integer
Dim a(1 To 9) As String
'Private Sub CommandButton1_Click()
For i = LBound(a) To UBound(a)
vector(i) = 0
Next i
With Sheets("Botón").ListBox1
Select Case (ListBox1.Text)
Case "Tornillo Resorte": vector(1) = 1
Case "Categoría Manguito": vector(2) = 1
Case "Estanqueidad": vector(3) = 1
Case "Exfoliación": vector(4) = 1
Case "Material vaina": vector(5) = 1
Case "Diseño EC": vector(6) = 1
Case "Curva Q vs Enriquecimiento": vector(7) = 1
Case "Curva Criticidad": vector(8) = 1
Case "Curva de carga t. enfriamiento": vector(9) = 1
Case "Condicioón de transporte": vector(10) = 1
Case "ATI": vector(11) = 1
Case ""
MsgBox "nothing selected"
Case Else
MsgBox Me.ListBox1.Text
End Select
Dim MN As String
For i = 1 To N 'Fill the array
a(i) = "macro" & i
Next
MN = "Módulo5" 'Module where i have the worksheet I'm working with
Dim N As Integer
N = 11
For i = LBound(a) To UBound(a)
If vector(i) = 1 Then
Application.Run MN & "." & a(i)
End If
Next i
End Sub
I find trouble with the Select Case (ListBox1.Text) statement.
It doesn't compile and don't know how to call the listBox with Select Case.
thank you in advance for your help :)
Edit: with a new code. Method with selection:
`Private Sub Command Button1_Click() 'This is a button that opens the multilist with the different options. It works correctly
Worksheets("Botón").ListBox1.Clear
ListBox1.Height=200
ListBox1.Width=250
Dim mylist As Variant
mylist=Array("Tornillo Resorte",...,"Condicioón de transporte")
ListBox1.List=mylist
End Sub
Sub Submit() ''here's the macro with the button assigned to execute the selection. This is where I get the problem.
With Sheets("Botón").ListBox1
MN = "Módulo5" 'Module where i have the worksheet I'm working with
For X = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(X) = True Then
Application.Run MN & "." & .ListIndex + 1
Else
MsgBox "No se ha seleccionado ningún filtro"
End If
Next X
End With
End Sub
If you only wanted to select one macro - and assuming the macros are named sequentially macro1 to macrox, then you can just do this:
Sub Submit()
With Sheets("Botón").ListBox1
if .listindex = -1 then
MsgBox "nothing selected"
Else
MN = "Módulo5" 'Module where i have the worksheet I'm working with
Application.Run MN & "." & .listindex +1
End If
End With
End Sub
If you want to do more than one then you need to loop through the .selected array calling the macros sequentially
I have just started using dictionaries and Class collections. I wrote a code using both that worked fine (see code below).
For a = 2 To UBound(FullArray, 1)
Set GEMclass = dict.Items(a) '<-------
GEM = GEMclass.g
'Do while loop
Do
'Check to see if Parent has an owner
If (Not (dict.Exists(GEM))) Then
Nrow = 0
Else
Nrow = dict(GEM).Num
Call Main
Call PartTwo
Call PartThree
End If
Loop Until (Nrow = 0) 'keep doing this unti no tree link
Next a
Call TurnOnFunctionality
End Sub
However, I tried to use the same line of code in another sub and it does not work (the line is in marked with an arrow).
Dim i As Integer
If ((GemDict.Exists(GEM))) Then
i = GemDict.Item(GEM)
i = i - 2
Set GEMclass = GemDict.Items(i) '<-------
'Debug.Print GemDict.Item(GEM)
'Debug.Print GemDict.Keys(i)
If GEMclass.NumofP > 1 Then
MsgBox "Greater 1"
Else
MsgBox "Only 1"
End If
End If
GEM = GEMclass.P
I declared both GEMclasses in each code as so
Public GEMclass As Gclass
Any ideas? I am stumped.
Please help with the following:
1) A code that sets a list of all macros of "Module3", and place this list in "Sheet5", starting in cell "E14" below.
2) Then, the code should run all the listed macros
I tried with a code that referred VBComponent, but I got an error.
Based on my google search, I found the answer That I commented you , but They forgot and important thing, that is check and option to allow you run the macro.
First the Function to list all macros in excel and return and string separated by white space:
Function ListAllMacroNames() As String
Dim pj As VBProject
Dim vbcomp As VBComponent
Dim curMacro As String, newMacro As String
Dim x As String
Dim y As String
Dim macros As String
On Error Resume Next
curMacro = ""
Documents.Add
For Each pj In Application.VBE.VBProjects
For Each vbcomp In pj.VBComponents
If Not vbcomp Is Nothing Then
If vbcomp.CodeModule = "Module_name" Then
For i = 1 To vbcomp.CodeModule.CountOfLines
newMacro = vbcomp.CodeModule.ProcOfLine(Line:=i, _
prockind:=vbext_pk_Proc)
If curMacro <> newMacro Then
curMacro = newMacro
If curMacro <> "" And curMacro <> "app_NewDocument" Then
macros = curMacro + " " + macros
End If
End If
Next
End If
End If
Next
Next
ListAllMacroNames = macros
End Function
The next step, of well could be the first one, you need to change some configuration of the office (Excel) trustcenter, check the follow images:
Step 1:
Step 2:
Step 3 (Final) Check the option "rely on access to the data model project vba":
Then you need to add this reference to your Excel:
Don't worry if you have another version of Microsoft Visual Basic for Applications Extensibility, in this case is 5.3. Check and then accept.Don't forget that you need to find that reference, there is no on the top of the list.
Finally you can invoke the ListAllMacroNames ( ) function With This other macro named execute () , Look That I 'm Validated That doesn't call the same macros (execute , ListAllMacroNames ) or could make an infinite loop.
Public Sub execute()
Dim AppArray() As String
AppArray() = Split(ListAllMacroNames, " ")
For i = 0 To UBound(AppArray)
temp = AppArray(i)
If temp <> "" Then
If temp <> "execute" And temp <> "ListAllMacroNames" Then
Application.Run (AppArray(i))
Sheet5.Range("E" & i + 14).Value = temp
End If
End If
Next i
End Sub
EDIT 2 Change "Module_name" in first method, to your desire module, and set the corret sheet name (in this case Sheet 5) in execute method.