VBA excel macro for a button that selects named reference from a named range
I have a named range "last_monday", which dynamically calculates one variable, last monday's date ("d-mmm-yy"). I'd like a macro that I can assign to a button which would select the column where last monday's date resides within a broader range of column-wise dates, called "date_range".
E.g. assuming today's date is Monday, 15-Jan-18, the button would select the cell in position BQ5 in the example below.
1 answer
-
answered 2018-01-14 11:45
Variatus
The function below selects the cell in
Date_Rangeindicated by the value ofLast_Monday. If there is no match it does nothing.Sub SelectMonday() Dim C As Long On Error Resume Next C = Application.Match(Range("Last_Monday").Value2, Range("Date_Range"), 0) If C Then Range("Date_Range").Cells(C).Select End Sub
See also questions close to this topic
-
VBA code crashes consistently on 4 out of 47 almost identical sheets when copying. Why?
I created a system of sheets for my employment office which organize volunteer information and schedules, and separates the schedules by month. When I want to add a new month, I have a macro that copies a "master" sheet for the month from the "master" workbook to all of the 47 different sheets. On four of these sheets, the below code crashes. On the remaining 43 it works just fine.
sourceBook.Sheets(Array("February, "Events", "Volunteers")).Copy _ After:=destinationBook.Sheets("Volunteers")The code inside the with also crashes the same sheets, but not the others.
With sourceBook.Sheets("February").UsedRange destinationBook.Sheets("February").Range("A1").Resize( _ .Rows.Count, .Columns.Count) = .Formula End WithOn all sheets, the February sheet does not exist, and Events and Volunteers do. The code later deletes the duplicates. Why would Excel crash on only some of them (they seem to be identical at surface level) for this copy? If you need additional information, I'll supply it.
-
Convert CSV to XPT file format- Python
I have completed manipulating xpt file data using pandas package in python.
Now I want to save this data frame into a new xpt file, however this does not exist yet.
Alternative solution is to save the df as csv file-- can someone share the solution to save csv file to xpt in python?
Thanks, Sagar
-
Clean data having multiple delimiters using vba
I have a list of manually entered ticket numbers with different delimiters and some strings. I am trying to clean it to just have the ticket numbers starting with "AK1" in a single string separated with commas.
-
Advice me in out of range problem of my cone creator
I've run this code and click draw I've found a out of range problem And Debugger give me a highlight to this line
Set coneobject = ThisDrawing.ModelSpace.AddCone(conecenter, coneradius, coneheight)But this is no mistake for me Can you suggest me ,please ?
Private Sub cmd_draw_Click() UserForm1.Hide Dim coneangle As Double Select Case comboboxangle.Text Case 0 coneangle = 15 Case 1 coneangle = 30 Case 2 coneangle = 45 Case 3 coneangle = 60 End Select Drawcone coneangle UserForm1.show End Sub Public Sub Drawcone(coneangle As Double) Dim coneobject As Acad3DSolid Dim conecenter As Variant Dim coneheight As Double 'Dim coneangle As Double Dim coneradius As Double coneheight = UserForm1.TextBox1.Text With ThisDrawing.Utility conecenter = .GetPoint(, vbCr & "select position for Top of cone:") End With conecenter(2) = conecenter(2) - coneheight / 2# coneradius = coneheight * Tan(coneangle) 'Set coneobject = ThisDrawing.ModelSpace.AddCone(conecenter, coneradius, coneheight) Set coneobject = ThisDrawing.ModelSpace.AddCone(conecenter, coneradius, coneheight) coneobject.Update ThisDrawing.ChangeViewDirection End Sub Private Sub cmd_finish_Click() Unload Me End Sub ''Private Sub cmd_pickpoint_Click() ''UserForm1.Hide ''Dim conecenter As Variant 'With ThisDrawing.Utility 'conecenter = .GetPoint(, vbCr & "select position for Top of cone:") 'End With 'UserForm1.show 'End Sub Private Sub UserForm_Initialize() With comboboxangle .AddItem "15" .AddItem "30" .AddItem "45" .AddItem "60" .Text = "Empty" End With End Sub -
Question on FSO and how to verify file integrity?
There is one button used to export PDF and Excel files from one application. Upon exporting completion, I will send out emails with all these files as attachments, but acturally, I face two problems when running below procedures. Are there any other solutions to verify the integrity of exported files?
Procedure ListFiles
As for procedure ListFiles, sometimes when I click on the export button, one error window will pop up on this line 'Str$ = Obj.Path', it states 'File Not Found', in VBA local window, I see that all the attributes of the variant Obj show as 'application-defined or object-defined error'. If I let the procedure ListFiles run some seconds after clicking on that export button, it will go smoothly.
Procedure ReadFiles and AccessRight
In the course of exporting, the file will appear in one target folder with its size as of 0 byte at the begining, and then in some seconds, it's size will become bigger and bigger. So with these two procedures, I can tell whether one file is occupied by another applocation or not. If all downloaded files are not occupied, I will put them attached in one email and send out. But in the actural running, one error window will show up from that application, it states 'the file is opened by other applications'. In my view, I guss the file may be occupied by this line in my procedure AccessRight, 'Open FilePath For Binary Lock Read Write As #1'
Sub ListFiles() Dim FSO As Object Dim FSO_Folder As Object Dim myPath$ Dim Obj Dim Str$ Dim k1 As Long myPath$ = "C:\Users\jim\Desktop\UIAutomation_VBA-master" Set FSO = CreateObject("Scripting.FileSystemObject") Set FSO_Folder = FSO.GetFolder(myPath) For Each Obj In FSO_Folder.Files Str$ = Obj.Path Next Obj End Sub Sub ReadFiles() Dim FSO As Object Dim FSO_Folder As Object Dim myPath$ Dim Obj Dim Str$ Dim k1 As Long myPath$ = "C:\Users\jim\Desktop\UIAutomation_VBA-master" Set FSO = CreateObject("Scripting.FileSystemObject") Set FSO_Folder = FSO.GetFolder(myPath) Do k1 = 0 For Each Obj In FSO_Folder.Files k1 = k1 + AccessRight(Obj.Path) Next Obj DoEvents Loop Until k1 = FSO_Folder.Files.Count End Sub Function AccessRight(ByVal FilePath As String) As Long On Error GoTo The_end AccessRight = 0 Open FilePath For Binary Lock Read Write As #1 Close #1 AccessRight = 1 The_end: End Function -
SQL syntax error in Excel VBA, can't root cause
I am having trouble with using the code below in an Excel VBA document. The SQL will run fine on Oracle SQL Developer but has a syntax error when running in Excel. I was wondering if anyone would be able to help with this.
SELECT RRNUMB , TRLNUM , LOCATN , D_CELL , F_CELL , E_CELL , C_CELL , IXD , CASE WHEN GREATEST(D_CELL,F_CELL,E_CELL,C_CELL) = D_CELL THEN 'D_CELL' WHEN GREATEST(D_CELL,F_CELL,E_CELL,C_CELL) = F_CELL THEN 'F_CELL' WHEN GREATEST(D_CELL,F_CELL,E_CELL,C_CELL) = E_CELL THEN 'E_CELL' WHEN GREATEST(D_CELL,F_CELL,E_CELL,C_CELL) = C_CELL THEN 'C_CELL' END CELL_PRIORITY FROM ( SELECT RRNUMB , TRLNUM , LOCATN , ROUND(((COUNT(DISTINCT(D_CELL))+COUNT(CASE WHEN FULL_ = 'MIXED' THEN 1 ELSE NULL END))/COUNT(FULL_))*100,2) D_CELL , ROUND((COUNT(DISTINCT(F_CELL))/COUNT(FULL_))*100,2) F_CELL , ROUND(((COUNT(DISTINCT(E_CELL))+COUNT(DISTINCT(IXD)))/COUNT(FULL_))*100,2) E_CELL , ROUND((COUNT(DISTINCT(C_CELL))/COUNT(FULL_))*100,2) C_CELL , ROUND((COUNT(DISTINCT(IXD))/COUNT(FULL_))*100,2) IXD FROM ( SELECT K2.RRNUMB , TR.TRLNUM , TR.LOCATN , CASE WHEN I.ULID IS NULL AND ITMGRP IN ('HAIR','SKIN','SHAVE','HOME','ORAL','PHC')THEN RE.ULID ELSE NULL END D_CELL , CASE WHEN I.ULID IS NULL AND ITMGRP IN ('APPLIA','FAMILY','FABRIC') THEN RE.ULID ELSE NULL END F_CELL , CASE WHEN I.ULID IS NULL AND ITMGRP = 'FEMCAR' THEN RE.ULID ELSE NULL END E_CELL , CASE WHEN I.ULID IS NULL AND ITMGRP = 'BABY' THEN RE.ULID ELSE NULL END C_CELL , CASE WHEN RE.ULID IS NULL THEN 'MIXED' ELSE 'FULL' END FULL_ , I.ULID IXD FROM TRAILER TR LEFT JOIN ( SELECT K1.SYSDAT, K1.TRLNUM, K1.TRKLIN, RRNUMB FROM ( SELECT MAX(SYSDAT) SYSDAT , TRLNUM , TRKLIN FROM SYSTRN ST WHERE TRNTYP = 'TRLASG' GROUP BY TRLNUM, TRKLIN ) K1 JOIN SYSTRN ST ON ST.SYSDAT = K1.SYSDAT AND ST.TRLNUM = K1.TRLNUM AND ST.TRKLIN = K1.TRKLIN WHERE TRNTYP = 'TRLASG' ) K2 ON TR.TRLNUM = K2.TRLNUM AND TR.TRKLIN = K2.TRKLIN JOIN RCPEXP RE ON K2.RRNUMB = RE.RRNUMB JOIN ITMMST IM ON RE.ITMCOD = IM.ITMCOD LEFT JOIN ixdshp i on re.rrnumb = i.rrnumb AND RE.ULID = I.ULID WHERE TR.LOCATN LIKE 'LOT%' ) GROUP BY RRNUMB , TRLNUM , LOCATN ) ;If anyone has information on this it would be greatly appreciated
-
Excel VBA Run-Time Error 424 Object Required
I'm trying to create a client intake form that allows the user to input information to be stored in another sheet for use later.
I've written this code and get a Run-time error '424' when I run the form. I've run out of ideas so I'd appreciate any help!
Private Sub OKButton_Click() Sheets("ClientList").Activate NextRow = Application.WorksheetFunction.CountA(Range("A:A")) + 1 Cells(NextRow, 1) = TextFirstName.Text Cells(NextRow, 2) = TextLastName.Text Cells(NextRow, 3) = ComboCaseStatus.Text 'potential bug Cells(NextRow, 4) = TextAdminFirstName.Text Cells(NextRow, 5) = TextAdminLastName.Text Cells(NextRow, 6) = TextAdminPhone.Text Cells(NextRow, 7) = ComboAdminRelation.Text 'potential bug Cells(NextRow, 8) = TextStreetAddress.Text Cells(NextRow, 9) = TextCityStateZIP.Text Cells(NextRow, 10) = TextPhoneNumber.Text Cells(NextRow, 11) = TextMailingAddr.Text Cells(NextRow, 12) = TextEmail.Text If OptionRetainer Then Cells(NextRow, 13) = "Retainer" If OptionPOA Then Cells(NextRow, 14) = "POA" If OptionAuthorization Then Cells(NextRow, 15) = "Authorization" If OptionIntakeForm Then Cells(NextRow, 16) = "Intake Form" Cells(NextRow, 17) = ComboStaffEnter.Text Cells(NextRow, 18) = Date TextFirstName.Text = "" TextFirstName.SetFocus TextLastName.Text = "" TextLastName.SetFocus TextAdminFirstName.Text = "" TextAdminFirstName.SetFocus TextAdminLastName.Text = "" TextAdminLastName.SetFocus TextStreetAddress.Text = "" TextStreetAddress.SetFocus TextCityStateZIP.Text = "" TextCityStateZIP.SetFocus TextPhoneNumber.Text = "" TextPhoneNumber.SetFocus TextMailingAddr.Text = "" TextMailingAddr.SetFocus Call SortDataDown End Sub -
How can I insert the ribbon under the page break everytime?
The point of this is to print a PDF page for our weekly schedule. C column has the start date for each job and I need a ribbon that takes up the whole row to beak up each day of the week in the schedule. I have a
Do While Loopthat checks C column and adds the ribbon for each new date but since there are multiple pages I also need the ribbon to show under each page break.The problem I'm running into is that the ribbon doesn't always get inserted under the page break but rather sometimes above it. I found a With Loop that handles the page breaks correctly each time but I don't know how to get it to work with my
Do While Loop. Basically, I can only either add the day of week ribbon under the page break OUR everytime the date of week changes.Sub forEachDayOfWeek() Range("A4").Formula = "=TEXT(C5,""dddd"")" Range("E6").Select Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Do While ActiveCell.Offset(-1, 0) <> "" And ActiveCell.Offset(0, -1) <> "" If ActiveCell.Value = 1 Then ActiveCell.Offset(2, 0).Select ElseIf ActiveCell.EntireRow.PageBreak <> xlPageBreakNone Then Rows("4:4").Copy Selection.EntireRow.Insert Shift:=xlDown ActiveCell.Offset(2, 0).Select ElseIf ActiveCell.Value = ActiveCell.Offset(-1, -2) Then ActiveCell.Offset(1, 0).Select ElseIf ActiveCell.Value = ActiveCell.Offset(-1, 0) Then ActiveCell.Offset(1, 0).Select ElseIf ActiveCell.Value > ActiveCell(-1, 0) Then Rows("4:4").Copy Selection.EntireRow.Insert Shift:=xlDown ActiveCell.Offset(2, 0).Select End If Loop Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub forEachPageBreak() Dim ws As Worksheet Dim PgBreak As HPageBreak Set ws = ActiveSheet With ws If .HPageBreaks.Count > 0 Then For Each PgBreak In .HPageBreaks Rows("4:4").Copy PgBreak.Location.Insert Next Else MsgBox "No data in sheets" End If End With End SubIn the picture, I have redacted some information but you can see the list of what I'm talking about. Tuesday is above the page break. Here is an image of the results
-
Python: Return the date of the next occurence of a third Thursday of the month
I'm somewhat new to Python and I've been really struggling with solving what seems like a simple problem, but I'm noticing all this code piling up and I'm just getting lost in the sauce.
I just need the date of the next occurrence of a third Thursday of the month, whether it is the present month or the following month.
This is different than the possible duplicate problem because I'm not testing to find if a given date was a third Thursday, I am simply looking to spit out the next occurrence of a third Thursday at the time which the script is run.
I look forward to being able to make stuff like this (or solve much more complicated problems!) but I really need to get this code running for something right now. I'd be really grateful if you can help me solve my conundrum, and maybe leave me some useful comments in the process!
Thank you so much.
-
MomentJS - date modified when sent over fetch request
I have an array of dates created with MomentJS:
[moment().subtract(2, "years"), moment()].I then send the array as a URL parameter with the following code:
const params = { timeRange: this.state.timeRange.map(date => date.valueOf()) } url.search = new URLSearchParams(params)However, when I deserialize the array on the server with
const start = moment(timeRange[0]) console.log(start) const end = moment(timeRange[1]) console.log(end)I get the following results:
moment("2001-01-01T00:00:00.000") moment("2001-04-01T00:00:00.000")For some reason, both of the years are 2001, which is incorrect. Why is this happening?
-
SQL Server : returning a cost based on a date range between 2 tables
I have 2 tables, one for transactions of inventory and one for standard cost history. I am trying to get the standard from the cost table by using the dates to determine what standard to select between the 2 tables.
So as an example:
ProductID Trans.Date ----------------------- P001 12/26/2017 P001 10/8/2018 P001 12/17/2018 P001 1/2/2019 ItemID EffectiveDate Standard --------------------------------- P001 12/23/2017 50 P001 12/31/2018 52 P002 12/23/2017 100 P002 12/31/2018 103My subquery is:
(SELECT SUM(c305.t_tvat_1) FROM tticpr305100 c305 WHERE c305.t_item = w112.t_item AND c305.t_indt <= w112.t_trdt) AS 'STD.COST'Where
tvat_1is the total value of materials, labour and other costs, andt_item = PRODUCT IDWhat I want to see:
ProductID Trans.Date STD_Cost --------------------------------- P001 12/26/2017 50 P001 10/8/2018 50 P001 12/17/2018 50 P001 1/2/2019 52What I am seeing:
ProductID Trans.Date STD_Cost --------------------------------- P001 12/26/2017 50 P001 10/8/2018 50 P001 12/17/2018 50 P001 1/2/2019 102
