I am new to Excel macros..
Can anyone tell me what this macro does?
Sub People_Add_Document()
prow = ActiveCell.row
num = Cells(prow, 1).Value
wshet = ActiveSheet.Name
If (Val(num) > 0) _
And (Cells(4, 1).Value = "#") _
And (wsheet = People_wsheet) _
Then
people_select_link_to_Document process_wbook_path, prow
End If
End Sub
Sub people_select_link_to_Document(process_wbook_path, prow)
If Len(Cells(prow, DocumentFile).Value) = 0 Then
Fname = Application.GetOpenFilename("Document Files (*.doc;*.pdf),*.doc;*.pdf", 1, "Select the Document file..")
If Fname <> False Then
Cells(prow, DocumentFile).Value = Fname 'global path
End If
End If
End Sub
Get the row number of the active cell:
prow = ActiveCell.row
Get the value in column 1 of that row:
num = Cells(prow, 1).Value
Read the name of the active worksheet (there is an error here, should read wsheet rather than wshet):
wshet = ActiveSheet.Name
Test if num is greater than 0, and the cell A4 contains "#" and the active worksheet is equal to a variable or constant called People_wsheet. And if so, a subroutine called people_select_link_to_Document is called with parameters process_wbook_path and prow
If (Val(num) > 0) _
And (Cells(4, 1).Value = "#") _
And (wsheet = People_wsheet) _
Then
people_select_link_to_Document process_wbook_path, prow
End If
Now, that subroutine first of all checks to see if the DocumentFile column of the active row is empty. Actually it's a rather lame way to test emptyness, but it will probably do.
If Len(Cells(prow, DocumentFile).Value) = 0 Then
And if it is empty then we show a file dialog to obtain a file name:
Fname = Application.GetOpenFilename("Document Files (*.doc;*.pdf),*.doc;*.pdf", 1, "Select the Document file..")
If a filename has been selected (i.e. the dialog is not cancelled) then we save that file name in the DocumentFile column of the active row for future reference:
If Fname <> False Then
Cells(prow, DocumentFile).Value = Fname 'global path
End If
And that's it!
Related
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.
Hi I'm trying to create macro that will collect data from excell table. I create strings with similar names and ended by number. Please is there a way to loop over this strings ? This Code is not working, but will explain what I want to do.
Sub vzor()
Dim i As Integer
Dim input1, input2, input3, input4, input5, input6, input7, _
input8, input9, input10, input11, input12, input13, input14, _
input15, input16, input17, input18, input19, input20, input21, _
input22, input23, input24, input25, input26, input27, input28, _
input29, input30, input31, input32, input33, input34, input35, _
input36, input37, input38, input39, input40, input41, input42, _
input43, input44, input45, input46, input47, input48, input49, _
input50, input51, input52, input53, input54, input55, input56, _
input57, input58, input59, input60, input61, input62, input63, _
input64, input65, input66, input67 As String
For i = 2 To 67
If Range("B" & i).Value = "" Then
MsgBox "Please fill all required data (The cells with red fill)", vbOKOnly, "Missing data"
Range("B" & i).Select
Else
input & i = Range("B" & i).Value
End If
Next
This seems to be a perfect example for a dictionary
Option Explicit
Dim wb As Workbook, ws As Worksheet
Dim inputdict As Variant
Dim i As Long
Set inputdict = CreateObject("Scripting.Dictionary")
Set wb = ThisWorkbook 'Change if necessary
Set ws = wb.Sheets(1) 'Change if necessary
For i = 1 To 67
If ws.Cells(i, "B").Value = vbNullString Then
MsgBox "Please fill all required data (The cells with red fill)", vbOKOnly, "Missing data"
ws.Cells(i, "B").Select
Else
inputdict.Add i, ws.Cells(i, "B").Value
End If
Next i
This creates a dictionary (inputdict). The keys for this dictionary are integers defined by i ranging from 1 to 67. The values are the values in the cells as you specified in your code already.
Hey I have been writing some code to add a part ID to a spreadsheet off of a user form in Excel VBA. I have been reading through different documentation and can not figure out why no matter what type of method of inserting a row I try it inserts a row with a repeating value instead of a blank one. If anyone knows how to specify blank, other than writing the whole row to blank and then writing my numbers I want after, that would be appreciated.
I have tried both the following lines to add a row
Cells (x+1 ,column).EntireRow.Insert Shift:= xlDown
ws1.Rows(x+1).Insert Shift:=xlDown
This is the function it is used in:
Public Sub Add(IDRange As Range)
SearchCell = Cells(x, IDRange.Column)
Cells(x, IDRange.Column).Select
Do
If SearchCell = PartID Then
MsgBox " this Company Already uses this part"
Exit Sub
ElseIf x <> StopRow Then
x = x + 1
SearchCell = Cells(x, IDRange.Column)
End If
Loop While x <> StopRow And SearchCell <> PartID
Cells(x + 1, IDRange.Column).EntireRow.Insert Shift:=xlDown
Cells(x, IDRange.Column).Value = PartID
MsgBox PartID & " has been added to Adress " & Cells(x, IDRange.Column).Address
Cells(x, IDRange.Column).Select
End Sub
Bellow is the function that calls the Add Function and where I belive it may be getting the company name from
Private Sub AddPart_Click()
AddPartCounter = 0
Company = UserForm1.CompanyBox.Value
PartID = UserForm1.PartBox.Value
If Company = "" Then
MsgBox " Please put in the company you would like the part to go under"
ElseIf PartID = "" Then
MsgBox " Please put in the Part you would like entered"
ElseIf UserForm1.Studs.Value = False And UserForm1.Spreaders.Value = False And UserForm1.Blocks.Value = False And UserForm1.Imma.Value = False Then
MsgBox "Please select the type of part you are trying to add"
Else
Dim CurrentCell
Set CurrentCell = Cells.Find(What:=Company, LookAt:=xlWhole)
If CurrentCell Is Nothing Then
MsgBox " Company Not Found "
Exit Sub
End If
x = CurrentCell.Row
Do
Set CurrentCell = CurrentCell.Offset(1, 0)
Loop While CurrentCell.Offset(1, 0) = "" And Not CurrentCell Is Nothing And CurrentCell.Offset(1, 0).Row <> thisvar.Row + 1
StopRow = CurrentCell.Row
'If they are trying to add a nut
If UserForm1.Imma.Value = True Then
Call Add(Nut_ID_Rng)
'IF they are trying to add a stud
ElseIf UserForm1.Studs.Value = True Then
Call Add(Stud_ID_Rng)
'If they are trying to add a block
ElseIf UserForm1.Blocks.Value = True Then
Call Add(Block_ID_Rng)
'If they are trying to add a spreader
ElseIf UserForm1.Spreaders.Value = True Then
Call Add(Spreader_ID_Rng)
End If
End If
AddPartCounter = 1
End Sub
I know that the repeating pattern is coming from the insert line through debugging but I can not figure out why I have tried changing variables to numbers and it still did the same thing. This what it looks like with the repeating values.
enter image description here
The problem is that you most likely have a value still stored in your clipboard when you execute the Macro. To fix that, simply add this line of dode before running the insert line:
Applcation.CutCopyMode = False
That will clear your clipboard and allow the inserted rows to be blank.
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.