I've browsed this site many times for answers and this is my first question. Great community here!
For a project I need to make an Excel sheet that suggests new Active directory groups based on their current active directory groups. For this I need the description field of the current active directory group (this is a mandatory field in our organization).
So I already have a script that can verify the existence of a Group by marking it with a colour. It's only 1 step of a multi step problem.
This doesn't retrieve the description information. And I have not found a working solution on the internet so far that I also understood.
A problem that might make it more complex is that the groups are in different Containers. This make the distinguished name prefix inconsistent.
Any help would be welcome.
Jeroen
Code so far. This reads ADgroups from column D (starting with D2) and searches it in active directory. Then it marks a cell with the colour green if it was found.
Sub ValidateGroupName()
Dim objController
Dim objGCController
Dim objConnection
Dim objCommand
Dim strADPath
Dim objRecordSet
Dim objFields
Dim Y As Integer
Dim GroupName As String
Dim ActSheet As String
Dim Descriptionname As String
ActSheet = ActiveSheet.Name
' Set up AD connection
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Open "Provider=ADsDSOObject;"
Set objCommand = CreateObject("ADODB.Command")
objCommand.ActiveConnection = objConnection
Set objController = GetObject("GC:")
' Get record from AD
For Each objGCController In objController
strADPath = objGCController.ADspath
'strADDescription = objGCController.ADspath
Next
Y = 0
Do
GroupName = Sheets(ActSheet).Range("D2").Offset(Y, 0).Value
objCommand.CommandText = _
"<" & strADPath & ">;(&(objectClass=Group)" & _
"(cn=" & GroupName & "));distinguishedName;subtree"
objCommand.Properties("Page Size") = 50000
Set objRecordSet = objCommand.Execute
' What to do with results?
If objRecordSet.RecordCount = 0 Then
'change color of a cell to red
Sheets(ActSheet).Range("E2").Offset(Y, 0).Interior.Color = 255
Else
' change color of a cell to green
Sheets(ActSheet).Range("E2").Offset(Y, 0).Interior.Color = 7138816
End If
Y = Y + 1
Loop Until Sheets(ActSheet).Range("D2").Offset(Y, 0).Value = ""
' Close AD connection
objConnection.Close
End Sub
I hope I'm on the right track, but a different approach might be a cleaner solution.
first, add 'description' property to your query :
objCommand.CommandText = _
"<" & strADPath & ">;(&(objectClass=Group)" & _
"(cn=" & GroupName & "));distinguishedName;subtree;Description"
second, get property value if group exist and write it beside group cell for example :
If objRecordSet.RecordCount = 0 Then
'change color of a cell to red
Sheets(ActSheet).Range("E2").Offset(Y, 0).Interior.Color = 255
Else
' change color of a cell to green
Sheets(ActSheet).Range("E2").Offset(Y, 0).Interior.Color = 7138816
Sheets(ActSheet).Range("E2").Offset(Y, 1).text = objRecordset.Fields("Description")
End If
Related
so essentially I have a cell that has a name, ie; "John Smith" and i want to have a button that splits the name into 2 or more pieces (depending on middle names) and pastes them into another cell.
i have the below code currently but i have no idea what im doing lol
any help would be appreciated :)
Private Sub Splitnames_Click()
Dim I As Integer
Dim WS1 As Worksheet: Set WS1 = Worksheets("sheet1")
Dim WS2 As Worksheet: Set WS2 = Worksheets("sheet2")
MyValue = InputBox("Please enter employee name...", "Import employee", "Enter employee name here...")
WS1.Range("E44").Value = MyValue
Dim FoundCell As Range: Set FoundCell = WS2.Range("A2:A1000").Find(WS1.Range("E44").Value, LookIn:=xlValues, LookAt:=xlPart)
If FoundCell Is Nothing Then
Set FoundCell = Nothing
Set WS1 = Nothing
Set WS2 = Nothing
MsgBox "No Employee found!"
Exit Sub
Else
Name = FoundCell.Offset(rowOffset:=0, columnOffset:=16).Value
SplitWords = Left(Name , 1)
For I = 2 To Len(Trim(Name ))
If (Asc(Mid(Name , I, 1)) > 64) And _
(Asc(Mid(Name , I, 1)) < 91) And _
(Mid(Name , I - 1, 1) <> " ") Then _
SplitWords = SplitWords & " "
SplitWords = SplitWords & Mid(Name , I, 1)
WS1.Range("C19") = SplitWords
Next
End If
Set FoundCell = Nothing
Set WS1 = Nothing
Set WS2 = Nothing
End Sub
I tried the above code but i cant figure out a way to paste the results into mulitple cells.
I need a way to paste result in Sheet1, Cell C19 then C20 then C21 and so forth.
This code splits the name based on where spaces are (so not exactly based on capital letters per the title of the question). To use this, remove all your code from the line SplitWords = Left(Name , 1) to Next (inclusive) and replace it with:
Dim nameArray As Variant
nameArray = Split(Name, " ")
WS1.Range("C19:C23").ClearContents
If UBound(nameArray) >= 0 Then
WS1.Range("C19").Resize(UBound(nameArray) + 1) = WorksheetFunction.Transpose(nameArray)
End If
This code assumes that your Name variable correctly has a name set into it ... I can't check that as I don't have a copy of the data in sheet1 and sheet2.
It also assumes that no name ever has more than 5 individual words ... if it does, increase the number of rows cleared in the WS1.Range("C19:C23").ClearContents line. This ensures that no individual words are left-over from previously processed names (if the previously processed name contains more individual words).
thanks for the answers, ended up going down a different route using ". " as a separator. im sure it could be modified to capital letters somehow if someone wants too see the code i came up with below;
Dim EmployeeSplit() As String, Employee As String, EI As Variant, EN As Integer
Employee = FoundCell.Offset(rowOffset:=0, columnOffset:=25).Value
If Employee = "" Then
Else
'Use Split function to divide up the component parts of the string
EmployeeSplit= Split(Employee, ". ", 4)
i = 0
For N = 0 To UBound(EmployeeSplit)
i = i + 2
'Place each split into the first column of the worksheet
WS4.Range("F" & 58 + i).Value = Replace(EmployeeSplit(N) & ". ", ". . ", ". ")
If WS4.Range("F" & 58 + i).Value = ". " Then
WS4.Range("F" & 58 + i).Value = ""
End If
Next N
End If
i used i = i + 2 because im using merged cells so i need it placed in every second cell.
I'm trying to simplify a file_split script to a point of self-service in my dept. No one really has any understanding of the language, so I was checking to see if any of this could be further simplified so coworkers don't have to update the code from the editor pane.
for instance, I have things like Basepath to designate where the files will be saved off. How can I change
Dim Basepath As String
Basepath = "C:\Users\File Cuts\"
directory as string
to something like this where a user can select a folder pathway?
Dim Basepath as filedialog
with basepath
.title = "Select save location"
.directory = .selecteditems(1)
end with
and then instances where I have specific columns to reference (target value columns for each new file, naming convention columns, etc...)
as in:
Dim Manager_Name, Login_ID, Leader
Manager_Name = SourceData(i,4)
Login_ID = SourceData(i,5)
Leader = SourceData(i,9)
to be inputted by an input box for column letter like:
Dim column_selection as variant
column_selection = InputBox("Enter Column Letter")
Manager_Name = SourceData(i,column_selection)
There are quite a few references that I'd like to see if I could change so that edits could be made without actually touching the code (the column ranges where variants like name, and login ID will be changing a lot)
rest of code:
Option Explicit
Sub File_Splits()
Dim Wb As Workbook
Dim SourceData, Mgr_Name, Login_Id
Dim i As Long, j As Long, k As Long, a As Long
Dim Destination_Cell As Range
Dim Basepath As String, strNewpath As String, strLeader As String
Basepath = "C:\File Cuts\" '1. paste in file save pathway, keep last \
Set Wb = Workbooks.Open("C:\File_Split_Mgr_Template.xlsx") '2. paste template ws address here
Set Destination_Cell = Wb.Worksheets("Manager Data").Range("A2") '3. Update worksheet name and target cell
With ThisWorkbook.Worksheets("Roster")
SourceData = .Range("I10", .Range("A" & Rows.Count).End(xlUp)) '4. change I10 to your last column letter, dont change the number(keep the 10)
End With
Wb.Activate
Call Speed_Up_Code(True)
For i = 1 To UBound(SourceData)
If SourceData(i, 5) <> Login_Id Then '5. change the 1 to login column #
If i > 9 Then
Destination_Cell.Select
strNewpath = Basepath & strLeader & "\" 'comment this out if folders aren't needed
If Len(Dir(strNewpathD, vbDirectory)) = 0 Then 'comment this out if folders aren't needed
MkDir strNewpath 'comment this out if folders aren't needed
End If 'comment this out if folders aren't needed
Wb.SaveCopyAs strNewpath & _
ValidFileName(Login_Id & "_" & Mgr_Name & "_File Name.xlsx") '6. update file name
End If
With Wb.Worksheets("Manager Data") '7. change to template sheet
.Rows(2 & ":" & .Rows.Count).ClearContents '8. change 2 to row after header(s)--if header isn't in row 1
End With
Mgr_Name = SourceData(i, 4) '9. change 1 to mgr name column
Login_Id = SourceData(i, 5) '10. change 2 to login ID column
strLeader = SourceData(i, 9) '11. change 5 to lvl 3 mgr column
j = 0
End If
a = 0
For k = 1 To UBound(SourceData, 2)
Destination_Cell.Offset(j, a) = SourceData(i, k)
a = a + 1
Next
j = j + 1
Next
If Len(Dir(strNewpath, vbDirectory)) = 0 Then
MkDir strNewpath
End If
SaveCopy Wb, strNewpath, Login_Id, Mgr_Name
Call Speed_Up_Code(False)
End Sub
Public Sub SaveCopy(Wb As Workbook, strNewpath As String, Login_Id, Mgr_Name)
Wb.SaveCopyAs strNewpath & _
ValidFileName(Login_Id & "_" & Mgr_Name & "_File Name.xlsx") '12. update file name
End Sub
Have you considered having a sheet called something like "Configuration" where users write to and your script can read from. Hidden or protected if necessary
For example, list all your configuration description in col A, and the user fills in the value next to in col B, So if A1 contains the text "Manager Name Column [A-Z] =" the user enters the value "D" or 4 in cell B1. The script become Mgr_Name = SourceData(i, wsConfig.range("B1")). I guess you could add validation to their entries.
Layout the sheet like a form in logical groups and highlight where the entry cells are. In a case like entering column names I would put them horizontal with the descripting above and entry cell below, that seems more natural. Protect all the cells except the highlighted ones.
I am trying to implement a find function in a userform in a textbox.
Once it detects that 4 digits have been input it looks for this value in a list of models in range ("C39:C102").
It returns the value of the cell that is two cells to the left of it (that's where the name of the group that the model number belongs to is stored), and changes the combobox to select that group automatically.
In the range ("C39:C102"), there are multiple model numbers per individual cell, as in:
C39= 9070, 4835, 2858, 2853
C40= 2374, 2737, 8857, 9895
etc.
The macro runs the first time after opening the Excel sheet but when I look for a second model number it goes to "not found".
Private Sub TextBox5_Change()
'when user inputs a model number automatically change the combo box below it to correct group
Dim rng1 As Range
Dim modelNum As String
If Len(TextBox5.Text) = 4 Then
modelNum = TextBox5.Value
Set rng1 = Range("C39:C102").Find(modelNum)
If Not rng1 Is Nothing Then
ComboBox1.Value = rng1.Offset(0, -2)
MsgBox "This tool (" & modelNum & ") belongs to " & rng1.Offset(0, -2) & " group."
Else
MsgBox modelNum & " not found"
End If
TextBox5.Value = ""
modelNum = ""
Set rng1 = Nothing
'ComboBox1.Value = ""
End If
End Sub
Your code works fine for me.
Instead of this:
Set rng1 = Range("C39:C102").Find(modelNum)
try being a bit more explicit:
Set rng1 = Range("C39:C102").Find(What:=modelNum, Lookin:=xlValue, LookAt:=xlWhole)
Find() settings in excel are "sticky" and unless you specify them explicitly you'll get whatever settings were last-used.
I know this is a duplicate, but 30 minutes of googling couldn't find an answer.
In Excel, at times extra cells or rows can become activated - usually by going too far down on a worksheet, "Activating" all 1M + rows. This has a negative impact on performance, both in memory, file size, and usability.
I previously saw a post of how you can "re-size" what Excel thinks is an activated cell, but I can't find it.
How do I resize (Using VBA) an Excel Spreadsheet's activated cells, preferably using VBA? (You can nuke and re-make the sheet... but I'd prefer to avoid that)
To be clear, I'm refering to the set of cells Excel thinks it needs to store and remember. For example, if you go to cell A1048576, put a period in the cell, hit enter, then delete it and scroll up, Excel "Remembers" that all 1048576 rows are now activated, and will continue to keep them around. You can tell this is happening partially due to the scroll bar.
A third way - I'd like to re-define where on the spreadsheet Excel takes me when I hit Ctr+End - it brings you to what it currently thinks is the last row and the last column, but it's incorrect, and I'd like to remind Excel what the correct boundaries are.
you are talking about UsedRange
to reduce it, you have to
1) clear everything from range (including formating; you can just delete rows/columns)
2) save document
In order to reset the last cell in an worksheet using VBA, you can use the following code that will clear the excess formatting:
Sub ClearExcessRowsAndColumns()
Dim ar As Range, r As Long, c As Long, tr As Long, tc As Long, x As Range
Dim wksWks As Worksheet, ur As Range, arCount As Integer, i As Integer
Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
Dim shp As Shape
If ActiveWorkbook Is Nothing Then Exit Sub
On Error Resume Next
For Each wksWks In ActiveWindow.SelectedSheets 'Applies only to selected sheets (can be more than one)
Err.Clear
Set ur = Nothing
'Store worksheet protection settings and unprotect if protected.
blProtCont = wksWks.ProtectContents
blProtDO = wksWks.ProtectDrawingObjects
blProtScen = wksWks.ProtectScenarios
wksWks.Unprotect ""
If Err.Number = 1004 Then
Err.Clear
MsgBox "'" & wksWks.Name & _
"' is protected with a password and cannot be checked." _
, vbInformation
Else
Application.StatusBar = "Checking " & wksWks.Name & _
", Please Wait..."
r = 0
c = 0
'Determine if the sheet contains both formulas and constants
Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
'If both fails, try constants only
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
End If
'If constants fails then set it to formulas
If Err.Number = 1004 Then
Err.Clear
Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
End If
'If there is still an error then the worksheet is empty
If Err.Number <> 0 Then
Err.Clear
If wksWks.UsedRange.Address <> "$A$1" Then
wksWks.UsedRange.EntireRow.Hidden = False
wksWks.UsedRange.EntireColumn.Hidden = False
wksWks.UsedRange.EntireRow.RowHeight = _
IIf(wksWks.StandardHeight <> 12.75, 12.75, 13)
wksWks.UsedRange.EntireColumn.ColumnWidth = 10
wksWks.UsedRange.EntireRow.Clear
'Reset column width which can also _
cause the lastcell to be innacurate
wksWks.UsedRange.EntireColumn.ColumnWidth = _
wksWks.StandardWidth
'Reset row height which can also cause the _
lastcell to be innacurate
If wksWks.StandardHeight < 1 Then
wksWks.UsedRange.EntireRow.RowHeight = 12.75
Else
wksWks.UsedRange.EntireRow.RowHeight = _
wksWks.StandardHeight
End If
Else
Set ur = Nothing
End If
End If
'On Error GoTo 0
If Not ur Is Nothing Then
arCount = ur.Areas.Count
'determine the last column and row that contains data or formula
For Each ar In ur.Areas
i = i + 1
tr = ar.Range("A1").Row + ar.Rows.Count - 1
tc = ar.Range("A1").Column + ar.Columns.Count - 1
If tc > c Then c = tc
If tr > r Then r = tr
Next
'Determine the area covered by shapes
'so we don't remove shading behind shapes
For Each shp In wksWks.Shapes
tr = shp.BottomRightCell.Row
tc = shp.BottomRightCell.Column
If tc > c Then c = tc
If tr > r Then r = tr
Next
Application.StatusBar = "Clearing Excess Cells in " & _
wksWks.Name & ", Please Wait..."
If r < wksWks.Rows.Count And r < wksWks.Cells.SpecialCells(xlCellTypeLastCell).Row Then
Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Cells.SpecialCells(xlCellTypeLastCell).Row)
ur.EntireRow.Hidden = False
ur.EntireRow.RowHeight = IIf(wksWks.StandardHeight <> 12.75, _
12.75, 13)
'Reset row height which can also cause the _
lastcell to be innacurate
If wksWks.StandardHeight < 1 Then
ur.RowHeight = 12.75
Else
ur.RowHeight = wksWks.StandardHeight
End If
Set x = ur.Dependents
If Err.Number = 0 Then
ur.Clear
Else
Err.Clear
ur.Delete
End If
End If
If c < wksWks.Columns.Count And c < wksWks.Cells.SpecialCells(xlCellTypeLastCell).Column Then
Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
wksWks.Cells(1, wksWks.Cells.SpecialCells(xlCellTypeLastCell).Column)).EntireColumn
ur.EntireColumn.Hidden = False
ur.ColumnWidth = 18
'Reset column width which can _
also cause the lastcell to be innacurate
ur.EntireColumn.ColumnWidth = _
wksWks.StandardWidth
Set x = ur.Dependents
If Err.Number = 0 Then
ur.Clear
Else
Err.Clear
ur.Delete
End If
End If
End If
End If
'Reset protection.
wksWks.Protect "", blProtDO, blProtCont, blProtScen
Err.Clear
Next
Application.StatusBar = False
MsgBox "'" & ActiveWorkbook.Name & _
"' has been cleared of excess formatting." & Chr(13) & _
"You must save the file to keep the changes.", vbInformation
End Sub
NOTE: This code was slightly adapted from the code provided in the XSFormatCleaner add-in made by AKeeler. It used to be available on CodePlex before the platform got discontinued (Archive).
Good Day,
really need some help here, im bad at VBA.
Had created a spreadsheet and recorded a macro to record checkin of staff. However, im having difficulties checking out with the corresponding users based on the name.
Could anyone help me out over here?
Thanks. Had attached the spreadsheet for your ref.
http://www.etechnopia.com/vish/Book1ss.xlsm
After much googling, This is what i did based on mikes solution
Dim name As String
Dim id As Integer
Dim checkin As Date
Dim checkout As Date
name = Range("d6").Value
id = Range("d7").Value
checkin = Now
Range("d10") = checkin
Help anyone? im my very best here.
firstly I recommend to use range names for the important cells of your sheet
D6 EmpName
D7 EmpNo
D10 ClockInTime
D11 ClockOutTime
H5..H11 DataTable
This will enable you to reference them by name instead of hardcoding their addresses (bad bad hardcoding :-/ )
Secondly, your [Button] must serve a dual purpose ... it has to decide if a user is clocked in or out and do different things
a hi-level META code, executed at pressing [Button4] could be
if user clocked in
write current time into ClockOutTime ' remark: this may be superfluous
find DataTable record (EmpName, ClockInTime)
write ClockOutTime into record (EmpName, ClockInTime)
erase EmpName, EmpID, ClockInTime, ClockOutTime
else
write current time into ClockInTime
find first blank record in DataTable
write EmpName, EmpID, ClockInTime into DataTable record
endif
How to decide if a user is clocked in? If many users are using the same sheet at the same time (meaning 5 emps go there, write in their names and clock in) you need to examine DataTable for the first record of EmpNane without a ClockOutTime - if found he/she is in and needs to be clocked out.
more later ...
OK ... sorry was interrupted by Lady Gaga concerto in Vienna/AT
so here's a full code for the button
Sub ButtonPressed()
Dim DB As Range, Idx As Integer
Set DB = Range("DataTable")
If Range("EmpName") = "" Or Range("EmpNo") = "" Then
MsgBox "Enter your name and ID before pressing the button", vbCritical + vbOKOnly, "missing input"
Exit Sub
End If
Idx = UserClockedIn()
If Idx <> 0 Then
DB(Idx, 4) = Date + Time()
DB(Idx, 5).Formula = "=" & DB(Idx, 4).Address(RowAbsolute:=False, ColumnAbsolute:=False) & "-" & DB(Idx, 3).Address(RowAbsolute:=False, ColumnAbsolute:=False)
DB(Idx, 5).NumberFormat = "[hh]:mm"
Range("EmpName") = ""
Range("EmpNo") = ""
Else
Idx = 2
Do While DB(Idx, 1) <> ""
Idx = Idx + 1
Loop
DB(Idx, 1) = Range("EmpName")
DB(Idx, 2) = Range("EmpNo")
DB(Idx, 3) = Date + Time()
End If
End Sub
Private Function UserClockedIn() As Integer
Dim DB As Range, Idx As Integer
Set DB = Range("DataTable")
UserClockedIn = 0
Idx = 2
Do While DB(Idx, 1) <> ""
If DB(Idx, 1) = Range("EmpName") And DB(Idx, 2) = Range("EmpNo") And DB(Idx, 4) = "" Then
UserClockedIn = Idx
Exit Function
End If
Idx = Idx + 1
Loop
End Function
#user502908: I have not documented it because I want you to find out exactly what it does and by that have a quick start into Excel-VBA :-) It doesn't do too much and there are some basic thechniques you will apply again & again if you go into VBA ... try to populate ranges "ClockInTime" and "ClockOutTime" :-)))
Book1ssNew.xlsm
have fun
I tried another simpler method which i could cope with
Sub yes()
Dim findId As Integer
Dim FirstAddress As String
Dim FindString As Integer
Dim Rng As Range
FindString = Range("d7").Value
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("F1:J100")
Set Rng = .find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
FirstAddress = Rng.Address
Rng.Offset(0, 2).Value = Now()
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub
Search entire spreadsheet given id, when id found, to indicate dynamically the checkin timing.