CDate vba


2020.08.29 13:35 Sulprobil sbTimeDiff


sbTimeDiff() - Calculate time between two time points but count only time as specified for week days and for holidays subtracted by break times if working time exceeds specified time
sbTimeDiff(dtFrom, dtTo, vwh [, vHolidays] [, vBreaks])
Calculate time between two time points but count only time as specified for week days and for holidays subtracted by break times if given for specified working time.
dtFrom - Datetime to count from
dtTo - Datetime to count to
vwh - 8 by 2 matrix defining start time and end time for each weekday and for holidays,first row for Mondays, 8th row for holidays
vHolidays - Optional. List of holidays (integer datetime). If a day is in the holiday list its time willnot be counted for any weekday - just for the time defined in row 8 of parameter vwh
vBreaks - Optional. N x 2 matrix specifying working time (sorted in ascending order) andbreak time to subtract if corresponding time for a day has been worked
This program is provided without warranties of any kind, either expressed or implied, including but not limited to warranties of title or implied warranties of merchantability or fitness for a particular purpose. Opinions expressed herein are subject to change without notice. I will not assume any liability for any loss or damage kind, arising, whether direct or indirect, caused by the use of any part of the information provided.
Enum mc_Macro_Categories mcFinancial = 1 mcDate_and_Time mcMath_and_Trig mcStatistical mcLookup_and_Reference mcDatabase mcText mcLogical mcInformation mcCommands mcCustomizing mcMacro_Control mcDDE_External mcUser_Defined mcFirst_custom_category mcSecond_custom_category 'and so on End Enum 'mc_Macro_Categories Function sbTimeDiff(dtFrom As Date, dtTo As Date, _ vwh As Variant, _ Optional vHolidays As Variant, _ Optional vBreaks As Variant) As Date 'Returns time between dtFrom and dtTo but counts only 'dates and hours given in table vwh: for example '09:00 17:00 'Monday '09:00 17:00 'Tuesday '09:00 17:00 'Wednesday '09:00 17:00 'Thursday '09:00 17:00 'Friday '00:00 00:00 'Saturday '00:00 00:00 'Sunday '00:00 00:00 'Holidays 'This table defines hours to count for each day of the 'week (starting with Monday, 2 columns) and for holidays. 'Holidays given in vHolidays overrule week days. 'If you define a break table with break limits greater zero 'then the duration of each break exceeding the applicable 'time for this day will be subtracted from each day's time, 'but only down to the limit time, table needs to be sorted 'by limits in increasing order: 'Break table example 'Limit Duration (title row is not part of the table) '6:00 0:30 '9:00 0:15 ' ' '(C) (P) Bernd Plumhoff 28-Aug-2020 PB V1.3 Dim dt2 As Date, dt3 As Date, dt4 As Date, dt5 As Date Dim i As Long, lTo As Long, lFrom As Long Dim lWDFrom As Long, lWDTo As Long, lWDi As Long Dim objHolidays As Object, objBreaks As Object, v As Variant With Application.WorksheetFunction sbTimeDiff = 0# If dtTo <= dtFrom Then Exit Function Set objHolidays = CreateObject("Scripting.Dictionary") If Not IsMissing(vHolidays) Then For Each v In vHolidays objHolidays(v.Value) = 1 Next v End If If Not IsMissing(vBreaks) Then vBreaks = .Transpose(.Transpose(vBreaks)) Set objBreaks = CreateObject("Scripting.Dictionary") For i = LBound(vBreaks, 1) To UBound(vBreaks, 1) objBreaks(CDate(vBreaks(i, 1))) = CDate(vBreaks(i, 2)) Next i End If lFrom = Int(dtFrom): lWDFrom = Weekday(lFrom, vbMonday) lTo = Int(dtTo): lWDTo = Weekday(lTo, vbMonday) If lFrom = lTo Then lWDi = lWDTo: If objHolidays(lTo) Then lWDi = 8 dt3 = lTo + CDate(vwh(lWDi, 2)) If dt3 > dtTo Then dt3 = dtTo dt2 = lTo + CDate(vwh(lWDi, 1)) If dt2 < dtFrom Then dt2 = dtFrom If dt3 > dt2 Then dt2 = dt3 - dt2 Else dt2 = 0# End If If Not IsMissing(vBreaks) Then dt2 = sbBreaks(dt2, objBreaks) End If sbTimeDiff = dt2 Set objHolidays = Nothing Set objBreaks = Nothing Exit Function End If lWDi = lWDFrom: If objHolidays(lFrom) Then lWDi = 8 If dtFrom - lFrom >= CDate(vwh(lWDi, 2)) Then dt2 = 0# Else dt2 = lFrom + CDate(vwh(lWDi, 1)) If dt2 < dtFrom Then dt2 = dtFrom dt2 = lFrom + CDate(vwh(lWDi, 2)) - dt2 If Not IsMissing(vBreaks) Then dt2 = sbBreaks(dt2, objBreaks) End If End If lWDi = lWDTo: If objHolidays(lTo) Then lWDi = 8 If dtTo - lTo <= CDate(vwh(lWDi, 1)) Then dt4 = 0# Else dt4 = lTo + CDate(vwh(lWDi, 2)) If dt4 > dtTo Then dt4 = dtTo dt4 = dt4 - lTo - CDate(vwh(lWDi, 1)) If Not IsMissing(vBreaks) Then dt4 = sbBreaks(dt4, objBreaks) End If End If dt3 = 0# For i = lFrom + 1 To lTo - 1 lWDi = Weekday(i, vbMonday) If objHolidays(i) Then lWDi = 8 dt5 = CDate(vwh(lWDi, 2)) - CDate(vwh(lWDi, 1)) If Not IsMissing(vBreaks) Then dt5 = sbBreaks(dt5, objBreaks) End If dt3 = dt3 + dt5 Next i Set objHolidays = Nothing Set objBreaks = Nothing sbTimeDiff = dt2 + dt3 + dt4 End With End Function Private Function sbBreaks(ByVal dt As Date, objBreaks As Object) As Date 'Subtract break durations from dt as long as it exceeds the break limit, 'but not below break limit. ' '(C) (P) Bernd Plumhoff 22-Mar-2020 PB V1.00 Dim dtTemp As Date Dim k As Long k = 0 Do While k <= UBound(objBreaks.keys) If dt > objBreaks.keys()(k) + objBreaks.items()(k) - dtTemp Then dt = dt - objBreaks.items()(k) dtTemp = dtTemp + objBreaks.items()(k) ElseIf dt > objBreaks.keys()(k) - dtTemp Then dt = objBreaks.keys()(k) - dtTemp Exit Do End If k = k + 1 Loop sbBreaks = dt End Function Sub DescribeFunction_sbTimeDiff() 'Run this only once, then you will see this description in the function menu Dim FuncName As String Dim FuncDesc As String Dim Category As String Dim ArgDesc(1 To 5) As String FuncName = "sbTimeDiff" FuncDesc = "Returns time between dtFrom and dtTo but counts only " & _ "time given in table vwh. Holidays given in vHolidays " & _ "overrule week days, all breaks given in vBreaks are " & _ "subtracted if corresponding time has been worked" Category = mcDate_and_Time ArgDesc(1) = "Start date and time where to count from" ArgDesc(2) = "End date and time to count to" ArgDesc(3) = "Range or array which defines which time to count during the week starting from Monday, " & _ "8 by 2 matrix defining start time and end time for each weekday (8th row for holidays)" ArgDesc(4) = "Optional list of holidays which overrule week days, define time to count in 8th row of vwh" ArgDesc(5) = "Optional. N x 2 matrix specifying working limit times (sorted in ascending order) and break" & _ " durations to subtract if corresponding time for a day has been worked (but not below limit time)" Application.MacroOptions _ Macro:=FuncName, _ Description:=FuncDesc, _ Category:=Category, _ ArgumentDescriptions:=ArgDesc End Sub 
submitted by Sulprobil to Sulprobil [link] [comments]

2020.06.28 02:46 IndominusX How would I edit this copy and paste VBA code to include other criteria in order to not break when duplicate values are found?

Hello. So I have two workbooks here. Pickorder here. Column A lists the dispatch times. Column B has route codes. Column D has the dispatch areas. Column E has the dsp taking the route. For example, CX19 dispatches at 6:15:00, at STG.A01 for HIQL. I then have this Wave planner sheet. This VBA code copies and pastes the route codes (column B) into the wave planner columns matching the dsp and staging location. However, unlike before, the pickorder I receive daily has duplicate staging locations at different times that I want to keep there. For example route codes that dispatch at 8:15:00 have dispatch area A also. Here it is in the pickorder. Example CX140 is also at STG.A01. However this has a different dsp and dispatch time than CX19. Whenever I run the macro it gives me error code '457', "this key is already associated with an element of this collection."
This code works perfectly if there are no duplicate dispatch zones. Here is how the wave planner should look like after the route codes are copied and pastied. How would I edit this code to match the criteria of the time and the dsp and not just the dispatch area? Thank you to anyone willing to help me. Here is the full code.
Sub AvoidDuplicates() Dim bk As Workbook Dim dict As Object Dim cell As Range Dim Sht As Worksheet For Each bk In Application.Workbooks If UCase(bk.Name) Like UCase("*Pick*order*") Then Exit For Next bk If bk Is Nothing Then MsgBox "Workbook not found", vbCritical Exit Sub End If Set dict = CreateObject("scripting.dictionary") For Each cell In bk.Sheets(1).Range("B2:B" & bk.Sheets(1).Range("B1048576").End(xlUp).Row) dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev_dsp(cell.Offset(0, 3).Value2), _ cell.Offset(0, -1).Value2, cell.Value2) Next cell If dict.Count = 0 Then MsgBox "Data not found", vbCritical Exit Sub End If Set Sht = ThisWorkbook.Sheets("C2 Wave Plan") For Each cell In Sht.UsedRange If cell.Value2 <> vbNullString And dict.exists(Trim$(cell.Value2)) Then For i = 1 To 3 With cell.Offset(0, i) If Trim$(Sht.Cells(3, .Column).Value2) = dict(Trim$(cell.Value2))(0) And _ CDate(Sht.Cells(2, .Column).MergeArea.Cells(1, 1).Value2) = CDate(dict(Trim$(cell.Value2))(1)) Then .Value2 = dict(Trim$(cell.Value2))(2) Exit For End If End With Next i End If Next cell End Sub Function abbrev_dsp(dspCode As String) As String Select Case dspCode Case "AROW" dspCode = "AW" Case "JPDG" dspCode = "JP" Case "HIQL" dspCode = "HQ" End Select abbrev_dsp = Trim$(dspCode) End Function 
The line of code giving the error is
dict.Add Trim$(cell.Offset(0, 2).Value2), Array(abbrev\_dsp(cell.Offset(0, 3).Value2), _ cell.Offset(0, -1).Value2, cell.Value2) 
duplicate staging locations
wave planner
submitted by IndominusX to excel [link] [comments]

2020.06.23 13:57 RelativeSpeed [EXCEL] Can you expand If Then statements past 1 line?

Hello everyone. I'm new to VBA and doing as much as I can to learn on my own, but I think I'm stuck/in need of a nudge in the right direction.
I'm trying to make a macro that takes month old products from one sheet and moves them to the bottom of the next sheet. Here is a screenshot of what I'm trying to move. Worksheet 1 and Worksheet 2
How do I write longer If Then statements? Am I in the right ballpark? Right now the below code just pastes "Sheets("Old").Select"; when I actually need it to paste the old rows. I appreciate the pointers!
Sub MoveOldProducts() ' This macro is supposed to move the products which are over a month old from the 'Incoming' worksheet to the bottom of the 'Old' worksheet Dim ws As Worksheet, cell As Range, rng As Range Set ws = ThisWorkbook.Sheets("Incoming") Lrow = ws.Range("E" & Rows.Count).End(xlUp).Row Set rng = Sheets("Incoming").Range("E2:E" & Lrow) For i = Lrow To 2 Step -1 Set cell = ws.Range("E" & i) If CDate(cell) <= Date - 30 Then cell.EntireRow.Cut Sheets("Old").Select Worksheets("Old").Range("A" & Rows.Count).End(xlUp).Offset(1).Select ActiveCell.PasteSpecial End If Next End Sub 
submitted by RelativeSpeed to vba [link] [comments]

2020.06.15 19:15 Rooqes Creating VBA Code To Get SUMIFS of Selected Cell Data

Hello, I am currently working on trying to create a userform in VBA that will take the values in a cell "F" and add them so long as the value in the date Column "K" are between certain dates. I also need another condition that includes the name column "H" having a certain value. Here is my code so far:
Private Sub date_box_Change() Dim STrange As Date, ENDrange As Date, date_value As Date, bolt_type As String date_value = date_box STrange = date_value ENDrange = DateAdd("d", 365, date_value) type_value = "*" & type_value & "*" Me.production_amount = Application.WorksheetFunction.SumIfs(Sheet2.Range("F1:F152"), _ Sheet2.Range("K1:K152"), ">=" & STrange, Sheet2.Range("K1:K152"), "<=" & ENDrange, _ Sheet2.Range("H1:H152"), type_value) End Sub Sub type_box_Change() Dim type_value As String Dim type_box As String If type_box = "BE LC A12" Then type_value = Array("BLA12", "BE LC A12") End Sub Private Sub Userform_Initialize() Me.date_box.AddItem CDate("1/1/2017") Me.date_box.AddItem CDate("1/1/2018") Me.date_box.AddItem CDate("1/1/2019") Me.date_box.AddItem CDate("1/1/2020") Me.type_box.AddItem "BE LC A12" End Sub 
I have the bit down where it will determine the year but I am having a problem trying to get the code to accept either "BE LC A12" OR "BLA12" as the same thing to look for. This problem arises from having the same thing named different ways by different people. I need the code to be able to do this for multiple things that are the same thing but named differently.
If I need to explain anything better or didn't explain anything that you would otherwise need explained please let me know. Thank you for any help!

Example Snippet

submitted by Rooqes to excel [link] [comments]

2020.06.03 09:17 UnpluggedUnfettered I had a report that I couldn't get to run any faster, so to keep people from asking me if there's any way to speed it up (it takes a minimum of 45 seconds) I turned it into a vs. game.

Today's dumb solution to a dumber problem made me laugh so I figured I would share it.
If you're in this subforum, at some point you've probably had to create a report that coworkers could run without your assistance . . . and you delivered. Even if it sucked to run. You have probably also promised yourself never to create things that might require anything resembling maintenance.
The job I had today was completely unavoidable because of [business reasons]. So very many people need to touch a workbook in a shared place, and it requires VBA, and it isn't fast. Also, they'll have to run it 3 or 4 times per day.
The end result, a thing works and it absolutely cannot be trimmed down below 40 seconds for a full run. Are you listening, Daryl.
It, by virtue of doing a thing, takes time to open, read from, write to, and close dozens of files.
I did not want people to ask me to take a look at it again in a few months. I also didn't want intermittent hints that maybe if i did [baffling thing] it would run faster. I wanted to be done when I was done, and a 45 second run times are not great for that want.
However, I also didn't want to leave a note in the workbook ("takes X seconds to run") or put effort into a loading bar. Besides, historically neither of those things helped. People still poke me about slower workbooks I did ages ago. I think the ones with the loading bars make people angrier.
I embarked on a dumb quest to make loading fun because, well fuck, look at all the loading I had to work with. Let me stop you right here and promise you that I failed to make loading fun . . . but the end result is as dumb as the problem I set out to solve.
At least it looks like I was aware it takes a long time to run, and also that I clearly wasn't able to do anything about it.
NOTE: as Excel likes to remind me, I can't share a macro enabled workbook . . . and doing any of this will be even worse than a loading bar if people can't compare high scores *in real time*.
Those are problems.
Well fuck you, problems.
Step 1:
Create a txt file in the same directory as the report, named HighScores.Bak (gotta change the extension after saving in notepad).
The text saved in the file is:
"Your Name Here1001/1/2020A Name Here too!10001/1/2020" 
without the quotes.
At the very beginning of my code I put in a start timer
Dim StartTime As Double Dim SecondsElapsed As Double StartTime = Timer 
Step 2:
at the veeerrrry end of my code just before End Sub, I add the following:
 'name for posterity Mememe = CStr(application.UserName) 'read the saved high scores file TextFile = FreeFile FilePath = ThisWorkbook.Path & "\HighScores.Bak" Open FilePath For Input As TextFile 'put the text from the high scores file into a variable HiScr = Input(LOF(TextFile), TextFile) 'close the file Close TextFile 'did we load it faster, in seconds, than 'the first person in the saved HighScores file 'if so, then they are both the daily and the all time high score 'champion so we duplicate them and save over the HighScores.Bak If SecondsElapsed < CDbl(Split(HiScr, "")(1)) Then Newline = Split(Split(Mememe, ", ")(1), " ")(0) & " " & Left(Mememe, 1) & _ " (" & Mememe & ")" & SecondsElapsed & "" & Format(Now(), "m/dd/yyyy") Newline = Newline & "" & Split(Split(Mememe, ", ")(1), " ")(0) & " " & Left(Mememe, 1) & _ " (" & Mememe & ")" & SecondsElapsed & "" & Format(Now(), "m/dd/yyyy") 'this time we're opening to save over the file Open FilePath For Output As TextFile Print #TextFile, Newline 'annnnnnnnd done Close TextFile 'BUT WHAT IF THEY AREN'T AS GOOD AS THE. BEST. EVER. Else 'Well in that case, if they're better then the last person who 'played TODAY then they're TODAY'S HIGH SCORE CHAMPION YAYYYY If SecondsElapsed < CDbl(Split(HiScr, "")(4)) Or CDate(Split(HiScr, "")(5)) < DateValue(Month(Now()) & "/" & Day(Now()) & "/" & Year(Now())) Then Newline = Split(Split(Mememe, ", ")(1), " ")(0) & " " & Left(Mememe, 1) & " (" & Mememe & ")" & _ SecondsElapsed & "" & Format(Now(), "m/dd/yyyy") Newline = Split(HiScr, "")(0) & "" & Split(HiScr, "")(1) & "" & Split(HiScr, "")(2) & "" & Newline Open FilePath For Output As TextFile Print #TextFile, Newline 'seriously never forget to do this Close TextFile End If End If If Newline <> "" Then HiScr = Newline 
Well from there you can do whatever, I guess.
I made a fancy leader-board next to the run button with the ALL TIME LOWEST RUN TIME and THE DAILY CHAMPION underneath.
Every time they click the button, they see an update to the latest bestest run times against their own. IT'S LIKE THEY'RE REALLY THERE.
The text file opens and closes without much add to overhead, no one can cheat by editing something in the workbook, and if I could make it run any faster why tf would I be wasting my time doing this instead?
Jesus christ this is the dumbest thing. Doing it.
The data splits out after the above code pretty simply to display however you please:
AllTimeName = split(HiScr , "")(0) AllTimeScore = split(HiScr , "")(1) AllTimeDate = split(HiScr , "")(2) DailyTimeName = split(HiScr , "")(3) DailyScore = split(HiScr , "")(4) DailyDate = split(HiScr , "")(5) 'SecondsElapsed is still holding how long they took this run 
tldr; I created an online gaming experience because I wish I never learned VBA and NO I CAN'T SPEED IT UP DARYL
submitted by UnpluggedUnfettered to excel [link] [comments]

2020.03.27 05:26 glytchedup Converting text to 2 digit year to date

I have an extract of text and dates that I pull and I'm trying to VBA some stats from it (ex. how many dates are more than 5 years old.) Problem is, the dates are text when I pull the extract and most of them (but strangely not ALL of them...) are in mm/dd/yy format. If I use the Datevalue() function or Cdate... or even if I just click the cell and change the format to date, excel changes the date from 05/05/19 to 05/05/9919. It adds 99 instead of 20 to every single date.
I can't find any examples of this happening... If I use the Excel error checking, I can choose to convert XX to 19XX or 20XX -- which does work - but I can't find any formula or VBA to use that excel logic to fix the dates. Any ideas would be welcome!!!
Default text Changed to Date formatting (either by using the home menu or =datevalue, or even if I retype the date exactly as is.
Name Date
Event A 5/5/19 5/5/9919
5/6/18 5/6/9918
submitted by glytchedup to excel [link] [comments]

2020.03.11 01:09 LemmeHoldaDollar Beginner troubles with Application InputBox, Date Variable, and RTE 6 Overflow

Hi VBA Redditors...
I am a beginner learning VBA in Excel for personal use. I should note that I am using Excel 16.34 on Mac, which I am suspecting to be relevant. As for the errors...all is going smoothly until I encounter the below difficulty while following a Wise Owl tutorial.
My code (below) is identical to the tutorial, but the FilmDate = Application.InputBox is giving me an overflow error. If I enter anything other than a known date literal (12/12/2012), then I get an invalid entry error. If I enter a correct date literal (12/12/2013), I get the overflow error.
Sub ApplicationInputbox() Dim FilmName As String Dim FilmLength As Integer Dim FilmDate As Date FilmName = Application.InputBox("Enter a film name", "Film Name") FilmLength = Application.InputBox(Prompt:="Enter Film Length", Type:=1) FilmDate = Application.InputBox(Prompt:="Enter a date dd/mm/yyyy", Title:="Film Release Date", Type:=1) Range("B2").End(xlDown).Offset(1, 0).Value = FilmName Range("B2").End(xlDown).Offset(0, 1).Value = FilmDate Range("B2").End(xlDown).Offset(0, 2).Value = FilmLength End Sub 
EDIT: If I use the InputBox instead of Application.InputBox, this all works fine.
I have searched for hours for a solution or some definitive information as to why this isn't working. I don't know much about the usage of CDate but I also tried (unsuccessfully) to fix it with that. Any help you can provide will be greatly appreciated!

Solved! I changed the FilmDate input box from this:
FilmDate = Application.InputBox(Prompt:="Enter a date dd/mm/yyyy", Title:="Film Release Date", Type:=1) 
To this:
FilmDate = DateValue(Application.InputBox(Prompt:="Enter a date dd/mm/yyyy", Title:="Film Release Date")) 
Thanks to those who commented and tried to help.
submitted by LemmeHoldaDollar to vba [link] [comments]

2020.02.11 16:42 GeoffPetterson VBA Command to send emails for dates within 35 days from today is stopping after it reaches the first date.

As the title says, I have a VBA Script i found online that is setup to email me when a cell is within 35 days from today's date. The issue i run into is that it only sees the first value, sends the email for that and then stops the command. I'm hoping to get the email to contain a complete list of these dates. pasted below is the current VBA.
Thank you all in advance for any assistance!
Public Sub CheckAndSendMail()
'Updated by Extendoffice 2019/12/10
Dim xRgDate As Range
Dim xRgSend As Range
Dim xRgText As Range
Dim xRgDone As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xLastRow As Long
Dim vbCrLf As String
Dim xMailBody As String
Dim xRgDateVal As String
Dim xRgSendVal As String
Dim xMailSubject As String
Dim i As Long
On Error Resume Next
Set xRgDate = Range("P2: P250")
If xRgDate Is Nothing Then Exit Sub
Set xRgSend = Range("S2: S250")
If xRgSend Is Nothing Then Exit Sub
Set xRgText = Range("F2:F250")
If xRgText Is Nothing Then Exit Sub
xLastRow = xRgDate.Rows.Count
Set xRgDate = xRgDate(1)
Set xRgSend = xRgSend(1)
Set xRgText = xRgText(1)
Set xOutApp = CreateObject("Outlook.Application")
For i = 1 To xLastRow
xRgDateVal = ""
xRgDateVal = xRgDate.Offset(i - 1).Value
If xRgDateVal <> "" Then
If CDate(xRgDateVal) - Date <= 35 And CDate(xRgDateVal) - Date > 0 Then
xRgSendVal = xRgSend.Offset(i - 1).Value
xMailSubject = "SMA Expiring Soon, PO# " & xRgText.Offset(i - 1).Value & " on " & xRgDateVal
vbCrLf = ""

xMailBody = ""
xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
xMailBody = xMailBody & "Text WEB SMA Will be expiring on: " & xRgDate.Offset(i - 1).Value & vbCrLf
xMailBody = xMailBody & ""
Set xMailItem = xOutApp.CreateItem(0)
With xMailItem
.Subject = xMailSubject
.To = xRgSendVal
.HTMLBody = xMailBody
End With
Set xMailItem = Nothing
End If
End If
Set xOutApp = Nothing
End Sub
submitted by GeoffPetterson to excel [link] [comments]

2019.05.09 16:09 awesome357 VBA macro type mismatch error when calling multiple subs

I am trying to setup a macro which will open a series of other workbooks based on cell references containing dates. Our filing and naming system is date dependent so it ends up complicated with needing a lot of different datestamps. The problem though is not in getting the files to open, but is in trying to get them all to open using a single macro. Either chaining the code in a single macro, or calling different subs for each file to be opened (like I'm posting here) is resulting in a type mismatch error. I can run the macros individually and they work perfect, but having a single macro calling the others causes this error on the second sub to run. I am far from an expert on VBA but I've gotten to where I am by extensive googling. If anyone has any idea why they run fine individually but not in a sequence, hopefully its something that Ill be able to understand. Code is pasted below. Thanks for any help given.

Sub Open_All() Call Open_Workbook1 Call Open_Workbook2 'etc... End Sub Sub Open_Workbook1() 'Set DateStamps formatting for the Excel filename DateStampA1 = Format(CDate(Range("A22")), "YYYY") DateStampB1 = Format(CDate(Range("A22")), "M") DateStampC1 = Format(CDate(Range("A22")), "MMM") DateStampD1 = Format(CDate(Range("A22")), "MM") DateStampE1 = Format(CDate(Range("A22")), "DD") 'Open workbook Dim my_FileName1 As Variant my_FileName1 = "N:\Lab Timesheets\" & DateStampA1 & " Time Sheets\" & DateStampB1 & " " & DateStampC1 & " " & DateStampA1 & "\" & DateStampD1 & "-" & DateStampE1 & "-" & DateStampA1 & ".xlsx" If my_FileName1 <> False Then Workbooks.Open Filename:=my_FileName1 End If 'Wait for workbook to open Application.Wait (Now + TimeValue("0:00:02")) End Sub Sub Open_Workbook2() 'Set DateStamps formatting for the Excel filename DateStampA2 = Format(CDate(Range("A23")), "YYYY") DateStampB2 = Format(CDate(Range("A23")), "M") DateStampC2 = Format(CDate(Range("A23")), "MMM") DateStampD2 = Format(CDate(Range("A23")), "MM") DateStampE2 = Format(CDate(Range("A23")), "DD") 'Open workbook Dim my_FileName2 As Variant my_FileName2 = "N:\La2 Timesheets\" & DateStampA2 & " Time Sheets\" & DateStampB2 & " " & DateStampC2 & " " & DateStampA2 & "\" & DateStampD2 & "-" & DateStampE2 & "-" & DateStampA2 & ".xlsx" If my_FileName2 <> False Then Workbooks.Open Filename:=my_FileName2 End If 'Wait for workbook to open Application.Wait (Now + TimeValue("0:00:02")) End Sub 
submitted by awesome357 to excel [link] [comments]

2019.03.01 08:00 PoopGooch VBA Routine throwing 'Runtime error 1004. Application Defined or object defined error' during copy paste.

Had to repost this as it was deleted for a poor title, hopefully this is better.
It's my first time using vba so it's been difficult. I've been able to get the first function working where it looks at cell J3 for a date, it then looks across a row of dates for the same date and saves the range. It then copies data from an input sheet and pastes it underneath this date. This all works perfectly.
I've tried to add in functionality so that on a Tuesday it copies done extra data and pastes it in cells offset from this first cell range where the date was found. It only partially works, it does the initial copy and paste and offsets but throws an error before completing the new copy and paste of the Tuesday data. The error it throws is 'Runtime error 1004. Application Defined or object defined error'
I've included the code below, it's probably a bit messy on account of me being a noob and I've typed it out here on my phone. Does anything stick out as being incorrect? I appreciate the help thank you.
 Private Sub CopyData_Click() Dim fD As Range, dt Dim LWeekday As Integer Dim day As Date Worksheets("INPUT").Range("BE5:BE42").Copy day = Date dt = CDate(Worksheets("INPUT").Range("j3").Value) Set fD = Worksheets("DATA").Range("J3:PQ3").Find(dt, LookIn:=xlValues) LWeekday = Weekday(Date, vbMonday) If Not fD Is Nothing Then Worksheets("DATA").Cells(4, fD.Column).PasteSpecial Paste:=xlPasteValues Worksheets("INPUT").Range("BE56:BE219").Copy Worksheets("DATA").Cells(43, fD.Column).PasteSpecial Paste:=xlPasteValues If LWeekday = 2 Then Worksheets("INPUT").Range("BE71:BE72").Copy Worksheets("DATA").Cells(43, fD.Column).Offset(15, -2).PasteSpecial Paste:=x1PasteValues End If End If End Sub 
submitted by PoopGooch to excel [link] [comments]

2019.01.15 14:47 Beautiful_Dirt [MSACCESS/SQLSERVER] JOIN to return all values in left table and zero if missing in right table?

Apologies firstly, as I think the title possibly makes this question sound far more difficult than it needs to be.
Essentially, I have two tables. In basic terms, it's a staff table and a "work completed" table. I'm trying to create a query that returns all the staff and the sum of the work they've done in a summary rows format.
The two tables:
+------------+-------------+----------------+--------------+ TM_StaffID TM_TeamName TM_TeamManager TM_StaffName +------------+-------------+----------------+--------------+ 1 HA11 David A Paul A 2 HA11 David A John A 3 HA11 David A Simon A 4 HA11 David A Peter A +------------+-------------+----------------+--------------+ 
+-------------+------------+----------+-------------+------------+---------------+-----------+ PS_TeamName PS_WorkID PS_Staff PS_WorkType PS_Date PS_WeekEnding PS_Points +-------------+------------+----------+-------------+------------+---------------+-----------+ HA11 2066944422 1 Dev 02/08/2018 05/08/2018 1 HA11 1869145859 1 * Misc. 02/08/2018 05/08/2018 0.75 HA11 2063035829 3 Plan 01/08/2018 05/08/2018 1 HA11 2036440149 3 * Misc. 02/08/2018 05/08/2018 0.5 HA11 2063023753 3 Patching 03/08/2018 05/08/2018 0.25 HA11 2012358108 4 Plan 03/08/2018 05/08/2018 0.25 HA11 2074311499 4 Dev 30/07/2018 05/08/2018 1 HA11 2075770157 4 Patching 01/08/2018 05/08/2018 0.75 HA11 2059475039 4 Patching 03/08/2018 05/08/2018 0.75 HA11 2062057110 4 Plan 30/07/2018 05/08/2018 0.25 HA11 2043715055 4 * Misc. 02/08/2018 05/08/2018 0.25 +-------------+------------+----------+-------------+------------+---------------+-----------+ 
The query I have written that works is here:
SELECT a.TM_StaffName as [Staff], Nz(Sum(p.PS_Points),0) AS [Total] FROM STAFF_TABLE as a LEFT JOIN WORK_TABLE as p ON a.TM_StaffID = p.PS_Staff AND cdate(ps.PS_Date) >= '2018-07-30') AND cdate(ps.PS_Date) <= '2018-08-05') WHERE a.TM_TeamName = 'HA11' GROUP BY a.TM_StaffName; 
The problem is, moving to SQLServer, that CDate isn't recognised as a function and fails on the query. Removing the CDate brackets then says that the JOIN function is not supported.
It seems to be a strange quirk but removing the CDate from the columns breaks the query as an unsupported join in Access.
Essentially, is there a better way to write this query so that ALL the staff names from the left table appear and if there are no matching records in the right table, it displays a zero?
An efficient and easy way of writing this results in the below tables returning 3 names on the left and 3 totals. But PS_Staff '2' should also display and show 0 instead of not appearing at all.
+---------+-------+ Staff Total +---------+-------+ Paul A 1.75 Simon A 1.75 Peter A 3.25 +---------+-------+ (Need John A - 0 to show in here) 
How can I achieve this to work with SQLServer and place the query in Access VBA?
submitted by Beautiful_Dirt to SQL [link] [comments]

2018.12.13 22:25 AssDimple VBA to automatically send an email based on defined due date.

I am trying set up a spreadsheet that automatically sends a reminder email to a specific email address when a due date is coming up. I found this VBA code that works but every time I run the macro I am prompted to reselect the due date, email address, and task.
I'm trying to find a way to set these items (ie Column A, B, C) so that when I open the workbook, it automatically scans the columns and sends the emails.
Am I missing something here?
For reference, here is the VBA Code:
Public Sub CheckAndSendMail() Dim xRgDate As Range Dim xRgSend As Range Dim xRgText As Range Dim xRgDone As Range Dim xOutApp As Object Dim xMailItem As Object Dim xLastRow As Long Dim vbCrLf As String Dim xMailBody As String Dim xRgDateVal As String Dim xRgSendVal As String Dim xMailSubject As String Dim i As Long On Error Resume Next Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8) If xRgDate Is Nothing Then Exit Sub Set xRgSend = Application.InputBox("Please select the recipients?email column:", "KuTools For Excel", , , , , , 8) If xRgSend Is Nothing Then Exit Sub Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8) If xRgText Is Nothing Then Exit Sub xLastRow = xRgDate.Rows.count Set xRgDate = xRgDate(1) Set xRgSend = xRgSend(1) Set xRgText = xRgText(1) Set xOutApp = CreateObject("Outlook.Application") For i = 1 To xLastRow xRgDateVal = "" xRgDateVal = xRgDate.Offset(i - 1).Value If xRgDateVal <> "" Then If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then xRgSendVal = xRgSend.Offset(i - 1).Value xMailSubject = xRgText.Offset(i - 1).Value & " on " & xRgDateVal vbCrLf = "

" xMailBody = "" xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf xMailBody = xMailBody & "Text : " & xRgText.Offset(i - 1).Value & vbCrLf xMailBody = xMailBody & "" Set xMailItem = xOutApp.CreateItem(0) With xMailItem .Subject = xMailSubject .To = xRgSendVal .HTMLBody = xMailBody .Display '.Send End With Set xMailItem = Nothing End If End If Next Set xOutApp = Nothing
End Sub
submitted by AssDimple to excel [link] [comments]

2018.11.19 16:54 outplay-nation Need help to integrate my VBA code inside a loop.

Hello everyone,

I have developed a code to that uses a VBA dictionary to associate date to events (strings) as seen below.
My input right now is only cells(2,9). When that cell contains an input event ( string) that is associated to a date in the dictionary, I gray out a range of cells and make them equal to 0 (range of cells within the same row as cells(2,9)).
My code works fine but I want to implement this so that my input can be any cell in the 9th column (I Column). Similarly the output should be taken on the same row as the input cell.

Any help is appreciated :)

Sub testMAC() Dim dict As New Scripting.Dictionary 'Date to closure criteria event association dict.Add CDate("01/01/19"), Array("event1", "event2", "event3") dict.Add Key:=CDate("01/02/19"), Item:=Array("event4", "event5") dict.Add Key:=CDate("01/03/19"), Item:=Array("event6") dict.Add Key:=CDate("01/04/19"), Item:=Array("event7", "event8", "event9", "event10") dict.Add Key:=CDate("01/05/19"), Item:=Array("event11", "event12", "event13") dict.Add Key:=CDate("01/06/19"), Item:=Array("event14") 'Headers Cells(1, 1) = "Risk" Cells(1, 2) = "12/01/18" Cells(1, 3) = "01/01/19" Cells(1, 4) = "02/01/19" Cells(1, 5) = "03/01/19" Cells(1, 6) = "04/01/19" Cells(1, 7) = "05/01/19" Cells(1, 8) = "06/01/19" Cells(1, 8) = "07/01/19" Cells(1, 9) = "Closure criteria" 'Macro recorder: delete used range of prior use of the code Range("B2:H2").Select Range("H2").Activate Selection.ClearContents With Selection.Interior .Pattern = xlNone .TintAndShade = 0 .PatternTintAndShade = 0 End With Range("I2").Select 'Loop implementation main body of the closure criteria function For i = LBound(dict.Item(CDate("01/01/19"))) To UBound(dict.Item(CDate("01/01/19"))) If Cells(2, 9) = dict.Item(CDate("01/01/19"))(i) Then Cells.Range("B2:H2").Interior.ColorIndex = 16 Cells.Range("B2:H2").Value = 0 End If Next i For j = LBound(dict.Item(CDate("01/02/19"))) To UBound(dict.Item(CDate("01/02/19"))) If Cells(2, 9) = dict.Item(CDate("01/02/19"))(j) Then Cells.Range("C2:H2").Interior.ColorIndex = 16 Cells.Range("C2:H2").Value = 0 End If Next j For k = LBound(dict.Item(CDate("01/03/19"))) To UBound(dict.Item(CDate("01/03/19"))) If Cells(2, 9) = dict.Item(CDate("01/03/19"))(k) Then Cells.Range("D2:H2").Interior.ColorIndex = 16 Cells.Range("D2:H2").Value = 0 End If Next k For L = LBound(dict.Item(CDate("01/04/19"))) To UBound(dict.Item(CDate("01/04/19"))) If Cells(2, 9) = dict.Item(CDate("01/04/19"))(L) Then Cells.Range("E2:H2").Interior.ColorIndex = 16 Cells.Range("E2:H2").Value = 0 End If Next L For M = LBound(dict.Item(CDate("01/05/19"))) To UBound(dict.Item(CDate("01/05/19"))) If Cells(2, 9) = dict.Item(CDate("01/05/19"))(M) Then Cells.Range("F2:H2").Interior.ColorIndex = 16 Cells.Range("F2:H2").Value = 0 End If Next M For N = LBound(dict.Item(CDate("01/06/19"))) To UBound(dict.Item(CDate("01/06/19"))) If Cells(2, 9) = dict.Item(CDate("01/06/19"))(N) Then Cells.Range("H2:H2").Interior.ColorIndex = 16 Cells.Range("H2:H2").Value = 0 End If Next N End Sub 

submitted by outplay-nation to vba [link] [comments]

2018.09.12 17:58 Its_ScaryTerry_Bitch Macro "Calls" work when F5 or F8 in Module but not when using an assigned button

Hello all! I'm having a pretty strange problem with my VBA calling another sub in the same workbook but different module.

The Problem:
I have multiple modules with public subs in them. When I go into the VBA and push F5 or step through the code with F8, everything runs fine without any freezing. The appropriate subs are all called as they should be.
However, when I push a button I have in the workbook that would run the macro, it fails to call the next sub. To be clear, it does still run the first sub that is directly assigned to the button, but when that sub is completed, it fails to call the next sub. I do not get an error, it just simply freezes excel and I must exit using the task manager.

The Code:
For the sake of quickness, I will simplify my sample code and skip to the end, since it is a long sub that I think is mostly irrelevant to this question (since this sub works fine).
The original sub, that is called from the button:
'Some code up here If Invoice Is Nothing Then GoTo Finished Finished: ieApp.Quit MsgBox ("Search completed!") Call CleanData End Sub 
I do get the "Search Completed" message box, and I can tell it did all the above code, it just doesn't seem to Call the next sub.

Here is the next sub that seems to NOT be called:
Public Sub CleanData() '***** Clean up selected data by trimming spaces, converting dates, and converting numbers to appropriate formats from text format ***** Dim MessageAnswer As VbMsgBoxResult Dim EachRange As Range Dim TempArray As Variant Dim rw As Long Dim col As Long Dim ChangeCase As Boolean Dim ChangeCaseOption As VbStrConv Dim rng As Range ChangeCaseOption = vbProperCase ChangeCase = False With Sheets("Email Check Pull").UsedRange .Resize(.Rows.Count - 1).Offset(1).Select End With Set rng = Application.Selection '***** Warn user if Range has Formulas ***** If RangeHasFormulas(rng) Then MessageAnswer = MsgBox("Some of the cells contain formulas. " _ & "Would you like to proceed and overwrite formulas with values?", _ vbQuestion + vbYesNo, "Formulas Found") If MessageAnswer = vbNo Then Exit Sub End If '***** Loop through each separate area the selected range may have ***** For Each EachRange In rng.Areas TempArray = EachRange.Value2 If IsArray(TempArray) Then For rw = LBound(TempArray, 1) To UBound(TempArray, 1) For col = LBound(TempArray, 2) To UBound(TempArray, 2) 'Check if value is a date If IsDate(TempArray(rw, col)) Then TempArray(rw, col) = CDate(TempArray(rw, col)) 'Check if value is a number ElseIf IsNumeric(TempArray(rw, col)) Then TempArray(rw, col) = CDbl(TempArray(rw, col)) 'Otherwise value is Text. Let's Trim it! (Remove any extraneous spaces) Else TempArray(rw, col) = Application.Trim(TempArray(rw, col)) 'Change Case if the user wants to If ChangeCase Then TempArray(rw, col) = StrConv( _ TempArray(rw, col), ChangeCaseOption) End If End If Next col Next rw Else 'Handle with Single Cell selected areas If IsDate(TempArray) Then 'If Date TempArray = CDate(TempArray) ElseIf IsNumeric(TempArray) Then 'If Number TempArray = CDbl(TempArray) Else 'Is Text TempArray = Application.Trim(TempArray) 'Handle case formatting (if necessary) If ChangeCase Then TempArray = StrConv(TempArray, ChangeCaseOption) End If End If End If EachRange.Value2 = TempArray Next EachRange MsgBox ("Data has been cleaned and formatted!") Call Edit_Final End Sub 
You can see that once this is done I would then like to call a third sub, but when using the assigned macro button, I don't even get to the start of the CleanData public sub.

Any ideas for this strangely specific problem?

Thank you!

submitted by Its_ScaryTerry_Bitch to excel [link] [comments]

2018.09.11 20:20 stileelits Non-tedious way to interpret date strings from different time zones?

I am integrating data from a csv (which I have no control over generating), and the csv stores dates in the following format:
April 20, 2018 10:20:27 AM PDT 
If you take that value and attempt to pass it to CDate or DateValue, you get a Run-time error 13: Type mismatch, because those functions are incapable of parsing this exact date format:
Const dateStr As String = "April 20, 2018 10:20:27 AM PDT" Debug.Print CDate(dateStr) 
Of course, it's trivially easy to simply remove the time zone information, and CDate can parse the remaining substring successfully:
Const dateStr As String = "April 20, 2018 10:20:27 AM PDT" Debug.Print CDate(Mid(dateStr, 1, InStrRev(dateStr, " ") - 1)) 
...however, this results in an inaccurate parse, IF my desired final time zone is different from the one given. In my case, the csv contains entries from both PST and PDT, so even if I wanted results in the Pacific time zone (which I don't), the results would still be incorrect for one of the daylight savings modes.
It's not particularly difficult to convert any timezone to UTC, but it's irritating to have to write an entire function with a massive Select Case block (not to mention the API call to get the current system time zone) just to interpret all the possible time zone codes. Is there an efficient and reliable way to do this in just a few lines of code, or do I really have to write this entire function and paste it into every VBA project that ever has to deal with time zones? Thanks!
EDIT: The general consensus seems to be that there isn't a slick way to do this, so I just wrote my own function:
Function UTCdate(dateLocal As Date, timeZoneCode As String) as Date Dim offset As Long Select Case timeZoneCode Case "BIT", "IDLW": offset = -12 Case "NUT", "SST": offset = -11 Case "CKT", "HST", "SDT", "TAHT": offset = -10 Case "MART", "MIT": offset = -9.5 Case "AKST", "GAMT", "GIT", "HDT": offset = -9 Case "AKDT", "CIST", "PST": offset = -8 Case "MST", "PDT": offset = -7 Case "CST", "EAST", "GALT", "MDT": offset = -6 Case "ACT", "CDT", "COT", "CST", "EASST", "ECT", "EST", "PET": offset = -5 Case "AMT", "AST", "BOT", "CDT", "CLT", "COST", "ECT", "EDT", "FKT", "GYT", "PYT", "VET": offset = -4 Case "NST", "NT": offset = -3.5 Case "ADT", "AMST", "ART", "BRT", "CLST", "FKST", "GFT", "PMST", "PYST", "ROTT", "SRT", "UYT": offset = -3 Case "NDT": offset = -2.5 Case "BRST", "FNT", "GST", "PMDT", "UYST": offset = -2 Case "AZOT", "CVT", "EGT": offset = -1 Case "AZOST", "EGST", "GMT", "UTC", "WET": offset = 0 Case "BST", "CET", "DFT", "IST", "MET", "WAT", "WEST": offset = 1 Case "CAT", "CEST", "EET", "HAEC", "IST", "KALT", "MEST", "SAST", "WAST": offset = 2 Case "AST", "EAT", "EEST", "FET", "IDT", "IOT", "MSK", "SYOT", "TRT": offset = 3 Case "IRST": offset = 3.5 Case "AMT", "AZT", "GET", "GST", "MUT", "RET", "SAMT", "SCT", "VOLT": offset = 4 Case "AFT", "IRDT": offset = 4.5 Case "HMT", "MAWT", "MVT", "ORAT", "PKT", "TFT", "TJT", "TMT", "UZT", "YEKT": offset = 5 Case "IST", "SLST": offset = 5.5 Case "NPT": offset = 5.75 Case "BIOT", "BST", "BTT", "KGT", "OMST", "VOST": offset = 6 Case "CCT", "MMT": offset = 6.5 Case "CXT", "DAVT", "HOVT", "ICT", "KRAT", "THA", "WIT": offset = 7 Case "AWST", "BDT", "CHOT", "CIT", "CST", "CT", "HKT", "HOVST", "IRKT", "MST", "MYT", "PHT", "PST", "SGT", "SST", "ULAT", "WST": offset = 8 Case "ACWST", "CWST": offset = 8.75 Case "CHOST", "EIT", "JST", "KST", "TLT", "ULAST", "YAKT": offset = 9 Case "ACST": offset = 9.5 Case "AEST", "CHST", "CHUT", "DDUT", "PGT", "VLAT": offset = 10 Case "ACDT", "LHST": offset = 10.5 Case "AEDT", "BST", "KOST", "LHST", "MIST", "NCT", "NFT", "PONT", "SAKT", "SBT", "SRET", "VUT": offset = 11 Case "FJT", "GILT", "MAGT", "MHT", "NZST", "PETT", "TVT", "WAKT": offset = 12 Case "CHAST": offset = 12.75 Case "NZDT", "PHOT", "TKT", "TOT": offset = 13 Case "CHADT": offset = 13.75 Case "LINT": offset = 14 End Select UTCdate = dateLocal - (offset / 24) 'offset is in hours, dates are in days, so you have to divide by 24 End Function 
Pass it a local date, and a time zone code, and it will return the UTC equivalent. Time zone data is from here:
I may have given up on this, but I'll leave this as "Unsolved" in hopes that someone will eventually add a comment with a brilliant and efficient method.
EDIT EDIT: I just noticed that there are some duplicate time zone codes...who the hell is in charge of standardizing these things, that they didn't bother ensuring that no time zone codes were duplicated? I'm particularly annoyed at Lord Howe, for reasons that will soon be apparent...anyway, the way the function is currently written, the LOWEST number offset will be selected for any duplicate Cases. So, if you ask for "PST", like I'm doing, the function will assume you mean UTC−08 Pacific Standard Time (North America) instead of UTC+08 Philippine Standard Time. That happens to be correct for what I need by pure coincidence, but if you need the other one, simply remove the incorrect time zone code from the block. (The bold entry is the one that will be selected if you don't do anything.)
AMT UTC−04 Amazon Time (Brazil)
AMT UTC+04 Armenia Time
AST UTC+03 Arabia Standard Time
AST UTC−04 Atlantic Standard Time
BST UTC+06 Bangladesh Standard Time
BST UTC+11 Bougainville Standard Time
BST UTC+01 British Summer Time (British Standard Time from Feb 1968 to Oct 1971)
CDT UTC−05 Central Daylight Time (North America)
CDT UTC−04 Cuba Daylight Time
CST UTC−06 Central Standard Time (North America)
CST UTC+08 China Standard Time
CST UTC−05 Cuba Standard Time
ECT UTC−04 Eastern Caribbean Time (does not recognise DST)
ECT UTC−05 Ecuador Time
GST UTC−02 South Georgia and the South Sandwich Islands Time
GST UTC+04 Gulf Standard Time
IST UTC+05:30 Indian Standard Time
IST UTC+01 Irish Standard Time
IST UTC+02 Israel Standard Time
LHST UTC+10:30 Lord Howe Standard Time
LHST UTC+11 Lord Howe Summer Time
MST UTC+08 Malaysia Standard Time
MST UTC−07 Mountain Standard Time (North America)
PST UTC−08 Pacific Standard Time (North America)
PST UTC+08 Philippine Standard Time
SST UTC−11 Samoa Standard Time
SST UTC+08 Singapore Standard Time
submitted by stileelits to vba [link] [comments]

2018.07.25 01:21 robertkmoore40 I can't seem to get my code to do what I want it to. I'm trying to scrape data from a folder using an FSO and its just not working. X = 0 or empty the debugger is skipping over my code. Is my code a mess?

Here is the code I'm using If anyone could help it'd be greatly appreciated. I'm a VBA nube and its showing!
Sub throwmamafromthetrain()
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Integer
Dim Invoice As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Set fldr = Fso.GetFolder("C:\temp2\")
y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
For Each wbFile In fldr.Files
y = ThisWorkbook.Sheets("sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
If Fso.GetExtensionName(wbFile.Name) = "xlsx" Then
Set wb = Workbooks.Open(wbFile.Path)
Application.ScreenUpdating = True
For Each ws In wb.Sheets
wslr = ws.Cells(Rows.Count, 1).End(xlUp).Row
If ws.Cells(8, 1) = ("Invoice #") Then
For x = 9 To wslr
ThisWorkbook.Sheets("Sheet1").Cells(y, 1) = ws.Cells(x, 1)
ThisWorkbook.Sheets("Sheet1").Cells(y, 2) = CDate(ws.Cells(x, 2))
ThisWorkbook.Sheets("Sheet1").Cells(y, 3) = ws.Cells(x, 3)
ThisWorkbook.Sheets("Sheet1").Cells(y, 4) = ws.Cells(x, 4)
ThisWorkbook.Sheets("Sheet1").Cells(y, 5) = ws.Cells(x, 5)
ThisWorkbook.Sheets("Sheet1").Cells(y, 6) = ws.Cells(x, 6)
ThisWorkbook.Sheets("Sheet1").Cells(y, 7) = ws.Cells(x, 7)
ThisWorkbook.Sheets("Sheet1").Cells(y, 8) = ws.Cells(x, 8)
ThisWorkbook.Sheets("Sheet1").Cells(y, 9) = ws.Cells(x, 9)
y = y + 1
Next x
End If
Next ws
End If
Next wbFile
End Sub
submitted by robertkmoore40 to vba [link] [comments]

2018.07.17 17:13 J__ro [VBA] Days and Months switched

I'm using the following VBA function to determine a date
Function RDWDatumTenaamstelling(kenteken) xlmPath = "" & kenteken If Len(kenteken) = 6 Then RDWDatumTenaamstelling = Application.IfError(CLng(CDate(Application.FilterXML(Application.WebService(xlmPath), "//datum_tenaamstelling"))), "Niet bekend RDW") Else RDWDatumTenaamstelling = "" End If End Function
The date gets delivered by the api in the dd/mm/yyyy format. It works ok but whenever the mm value is lower than 12 it gets switched with the dd value. Example: The value SV609N gets 07/06/2018 from the api endpoint and should return 7-6-2018, but it returns 6-7-2018.
I've been using my google-fu but to no avail!
submitted by J__ro to excel [link] [comments]

2018.05.21 12:41 TanyaD123 How to make code work on both PC and MAC

I have got some code that is working beautifully on PC but not when the file is used on Mac. I'm hoping there is a way to get the code to work on both PC and MAC as we have two people needing to use the file, one with PC and one with a MAC. Any suggestions hugely appreciated!
The code is so you can select one or more staff members, and then a date range so you can see the schedule for those selected staff for the selected date range. By 'not working' on MAC there are no error messages or any line of code highlighted, it simply just shows the first column (the first staff member only for the first date only), rather than the columns selected (via whatever staff & dates combo).
On the PC the Excel info says: Microsoft Office Pro Plus 2016 16.0.9029.2253 Version 1802 (Build 9029.2253 Click-to-Run)
On the Mac the Excel info says:Microsoft Excel for MacVersion 16.11.1 (180319)
The code is:
Sub HideStaffDate()
Rows(2).Hidden = True
Rows(3).Hidden = False
Dim Ans As Variant
Dim Dstart As String, Dend As String
Dim Cnt As Long
Ans = InputBox("Please enter staff membes (separating names with commas)")
If Ans = "" Then Exit Sub
Dstart = InputBox("Enter a start date")
If Dstart = "" Then Exit Sub
Dend = InputBox("Enter an end date")
If Dend = "" Then Exit Sub
Sheets("Staff").UsedRange.Offset(, 1).EntireColumn.Hidden = False
For Cnt = 3 To Cells(3, Columns.Count).End(xlToLeft).Column
If (Cells(3, Cnt) < CDate(Dstart) Or Cells(3, Cnt) > CDate(Dend)) Or InStr(1, Ans, Cells(4, Cnt), vbTextCompare) = 0
Then Columns(Cnt).Hidden = True
End If
Next Cnt
End Sub
Sorry if there is an obvious solution to this - I am very new to the world of VBA :-)
The other code (to then unhide all columns so can see all staff for all dates) works fine on MAC:
Sub UnhideAll()
Rows(2).Hidden = False
Rows(3).Hidden = True
Columns.EntireColumn.Hidden = False
End Sub
Thanks for any thoughts on this,
Tanya :-)
submitted by TanyaD123 to excel [link] [comments]

2018.03.28 12:54 Dekstar Formatting issue with text date to datetime conversion

Hi all,
I have a dataset with a date column that is formatted as: "d MMM yyyy at hh:mm" e.g. "15 Feb 2018 at 14:55" or "1 Feb 2018 at 09:23"
As this format is not natively readable by excel I'm trying to use VBA to put it into the following format: "dd/mm/yyyy hh:mm:ss"
No matter what I try, if the date has double digits at the start the cell correctly returns in the format I want, but if the date has only one digit there will be two spaces in the result between the date and the time, and the "00"s will not appear: "01/02/2018 09:23"
So far I've tried:
StartDate = Cdate(Left (source.Worksheets("sheet1").range("F" & currentrow), 11)) This correctly returns the date from the source cell. Also using format with "short date" works
Then using StartTime = format of right to 5 digits as "long time" returns the correct time
Then using result = StartDate & " " & StartTime produces the error.
Worksheetfunction.trim or replace on the final result doesn't work either.
Even having one cell as = StartDate&StartTime then another cell referencing it using (left to 10 digits) & " "& (right to 5 digits) makes the error come back.
I've googled for ages and have tried multiple solutions but nothing is working. Sorry for the formatting, I'm on mobile.
submitted by Dekstar to excel [link] [comments]

2018.01.24 02:18 MTGthesis Countifs Problem

Hi I have a column of dates K:K with each date recurring multiple times if I use the following code VBA returns 14, This tells me 22/1/2018 occurs 14 times.
Worksheets("Daily").Cells(5, 1).Value = 22/1/2018
Worksheets("Daily").Cells(6, 1).Value = 21/1/2018
Datecount = Application.WorksheetFunction.CountIf(Worksheets("Delay").Range("k:k"), CDate(CDbl(Worksheets("Daily").Cells(5, 1).Value)))
If I change this code to count how many occurrences of a date greater than 21/1/2018 there are it returns 1. See code below
Datecount = Application.WorksheetFunction.CountIf(Worksheets("Delay").Range("k:k"), ">" & CDate(CDbl(Worksheets("Daily").Cells(6, 1).Value)))
submitted by MTGthesis to vba [link] [comments]

2018.01.15 11:20 christizzz Adding Data to Filtered Column

So i have a VBA Code that lets me fill a USerform and then add the corresponding data to the next free row. Now i i have filter activated in Excel, the code overwrites the data on an already filled row. i guess it is because when filtered is on the row is not visible. How can i add data to a filtered column ?
thank you
Private Sub btnSubmit_Click() Dim ssheet As Worksheet Dim a As String Set ssheet = Application.ActiveSheet Dim Foundcell As Range Dim search As String Dim erow As Long nr = ssheet.Cells(Rows.Count, 1).End(xlUp).row + 1 If Me.Namelist.Value = "" Then MsgBox "Bitte Bearbeiter auswaehlen", vbInformation Exit Sub End If If Me.cmbListItem.Value = "" And nr > 3 Then MsgBox "Bitte Basis auswaehlen", vbInformation Exit Sub End If If Me.Allgemein.Value = False And Me.Front.Value = False And Me.Heck.Value = False And Me.Seite.Value = False And Me.Dach.Value = False And Me.Gurt.Value = False Then Cancel = 1 MsgBox "Bitte Dizipline auswaehlen", vbInformation Exit Sub End If If Me.Variante.Value = "" Then MsgBox "Bitte Variant auswaehlen", vbInformation Exit Sub End If If Me.Aenderungen.Value = "" Then MsgBox "Bitte Aenderungen auswaehlen", vbInformation Exit Sub End If erow = Application.ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).row search = Variante.Text Set Foundcell = Application.ActiveSheet.Columns(4).Find(search, LookIn:=xlValues, lookat:=xlWhole) If Foundcell Is Nothing Then ssheet.Cells(nr, 4) = Me.Variante Else MsgBox "Variant Name existiert schon" Exit Sub End If Range("A" & nr & ":g" & nr).Select Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ColorIndex = 0 .TintAndShade = 0 .Weight = xlThin End With ssheet.Cells(nr, 1) = CDate(Me.Tbdate) ssheet.Cells(nr, 2) = Me.Namelist If Me.Allgemein.Value = True Then ssheet.Cells(nr, 3) = "Allgemein" ElseIf Me.Front.Value = True Then ssheet.Cells(nr, 3) = "Front" ElseIf Me.Heck.Value = True Then ssheet.Cells(nr, 3) = "Heck" ElseIf Me.Seite.Value = True Then ssheet.Cells(nr, 3) = "Seite" ElseIf Me.Dach.Value = True Then ssheet.Cells(nr, 3) = "Dach" ElseIf Me.Gurt.Value = True Then ssheet.Cells(nr, 3) = "Gurt" End If ssheet.Cells(nr, 5) = Me.cmbListItem ssheet.Cells(nr, 6) = Me.Aenderungen ssheet.Cells(nr, 7) = Me.Bemerkungen Unload Me End Sub Private Sub cmbListItem_Change() Me.Variante = Me.cmbListItem End Sub Private Sub UserForm_Initialize() For Each cell In [List] Me.cmbListItem.AddItem cell Next cell Tbdate.Text = Format(Now(), "Short Date") End Sub Private Sub Variante_Click() End Sub 
submitted by christizzz to excel [link] [comments]

2017.02.12 01:51 Nightmareish Have a spreadsheet? Want to automatically calculate WHEN you'll be under 5/24? Use my Excel VB function!

Hi folks of /churning! I've recently become quite attached to this subreddit and I thought I'd give back. I'm a novice programmer, but I love doing little scripting projects here and there. This was definitely one of them.
If you're like me (and I assume many of you are), you have an Excel spreadsheet somewhere which contains information on all of your open credit lines, including their approval/opening dates. Say you're an active churner and you're churning a ton of cards -- you might want to know the exact date of when you'll be under 5/24. With this easy-to-use custom Excel UDF (user-defined function), programmed in VB, you'll be able to do just that, instantly, without batting an eye. All you have to do is feed the formula the cells which contain all of your account opening dates. It does the rest. I call it the UNDER 5/24 formula (not a catchy name, I know... suggestions?). See syntax:
UNDER524(acc_open_dates, [result_format]) 
Simply place the formula as written above, with or without the optional second argument, in ANY CELL by using the '=' prefix. As far as options for the result format, you have 3 as of this version.
result_format: "day" = returns number of days until under 5/24 "mfrac" = returns approximate number of months until under 5/24 (not exact; ballpark math) "date" = returns full date (mm/dd/yyyy) of when under 5/24 (omitting the option provides this result) 
Depending on which options you use, you may have to edit the cell formatting to match your selection. Use the hotkey CTRL + 1 with your cell selected to see the cell formatting options. Choose DATE formatting for UNDER524's default options, and general for "day" and "mfrac" options (alternatively, with the cell selected, type the keystroke CTRL + SHIFT + ~
First you should make your spreadsheet into an .xlsm (macro-enabled workbook) by first saving it as such in File -> Save As. Then, with your workbook open, use the keystroke Alt + F11 to open the VBA macro editor. In the Project Explorer tree, right click and Insert -> Module. Paste the code at the bottom of this post in. Now, go back to your worksheet and insert the function as a regular Excel formula!
I will probably be periodically updating this if I notice egregious bugs -- please post them! I also plan on writing another script to calculate the date at which a user will have X/24 accounts, with the user defining the X value. There are other ideas I've already implemented myself which I will add also once they are perfect, such as a function for AAoA, Depth of Credit history (Years & Months), and other things that might be useful if you can't get your hands on your full credit report.
Public Function UNDER524(acc_open_dates As Range, Optional result_format As String) As Variant Dim k As Range, z As Range Dim Date_OpenAccs_Past2yr As Variant Dim dateResult As Boolean 'Set current date and define limits Today = CDate(Day(Now) & " " & MonthName(Month(Now), True) & " " & Year(Now)) Today_Minus_Two_Years = CDate(Today_Day & " " & _ Today_Month & " " & Today_Year - 2) 'Determine if input range contains any valid data 'If no valid numbers, return #NUM! error For Each z In acc_open_dates If Not IsEmpty(z) And Not WorksheetFunction.IsText(z) _ And Not WorksheetFunction.IsErr(z) Then validCount = validCount + 1 Else errorCount = errorCount + 1 End If Next z If validCount = 0 Or errorCount > 0 Then UNDER524 = CVErr(xlErrNum) Exit Function End If 'Build array of account opening dates for 'all accounts opened within two years of today For Each k In acc_open_dates If k >= Today_Minus_Two_Years Then x = x + 1 If Not IsEmpty(Date_OpenAccs_Past2yr) Then ReDim Preserve Date_OpenAccs_Past2yr(x) Else ReDim Date_OpenAccs_Past2yr(1) End If Date_OpenAccs_Past2yr(x) = k End If Next k 'Sort array of account opening dates ascending If Not IsEmpty(Date_OpenAccs_Past2yr) Then If UBound(Date_OpenAccs_Past2yr) >= 5 Then dateResult = True Date_OpenAccs_Past2yr = BubbleSrt(Date_OpenAccs_Past2yr) End If End If 'Identify and operate on array element which will 'tip the scale for less than 5 new accounts in 24 months If dateResult = True Then Array_Target = Abs(4 - x) Target_Date = Date_OpenAccs_Past2yr(Array_Target) Target_Plus_Two_Years = CDate(Day(Target_Date) + 1 & " " & _ MonthName(Month(Target_Date), True) & " " & Year(Target_Date) + 2) GoTo result_format Else UNDER524 = "Current" End If 'Optional result formats If dateResult = True Then If result_format = "day" Then If (Target_Plus_Two_Years - Today) < 0 Then UNDER524 = "Current" Else UNDER524 = Target_Plus_Two_Years - Today End If ElseIf result_format = "mfrac" Then 'approximate mfrac = DateDiff("m", Now, Target_Plus_Two_Years) _ - (((Target_Plus_Two_Years - Today) Mod 12) / (365 / 12)) If mfrac < 0 Then UNDER524 = "Current" Else UNDER524 = mfrac End If ElseIf result_format = "date" Then If Today > Target_Plus_Two_Years Then UNDER524 = "Current" Else UNDER524 = Target_Plus_Two_Years End If Else: If Today > Target_Plus_Two_Years Then UNDER524 = "Current" Else UNDER524 = Target_Plus_Two_Years End If End If End If End Function Public Function BubbleSrt(ArrayIn) Dim SrtTemp As Variant Dim i As Long Dim j As Long For i = LBound(ArrayIn) To UBound(ArrayIn) For j = i + 1 To UBound(ArrayIn) If ArrayIn(i) > ArrayIn(j) Then SrtTemp = ArrayIn(j) ArrayIn(j) = ArrayIn(i) ArrayIn(i) = SrtTemp End If Next j Next i BubbleSrt = ArrayIn End Function 
Please ask any questions! Or, if you have information that suggests my calculations are wrong, please share! Thanks!
submitted by Nightmareish to churning [link] [comments]

Excel VBA UserForm TextBox - How to format date - YouTube How to use the FORMAT Function with Dates - YouTube VBA - Funções de Data (CDate, IsDate, Year, Month, Day) Excel VBA - Using Date, CDate, DateAdd function - YouTube Excel VBA Input Box for Dates - Code Included Excel VBA Date Function - YouTube C Date im Test  Die Bedienung von C Date - YouTube Date Picker Control - Excel VBA Data Entry Userform (Part ...

  1. Excel VBA UserForm TextBox - How to format date - YouTube
  2. How to use the FORMAT Function with Dates - YouTube
  3. VBA - Funções de Data (CDate, IsDate, Year, Month, Day)
  4. Excel VBA - Using Date, CDate, DateAdd function - YouTube
  5. Excel VBA Input Box for Dates - Code Included
  6. Excel VBA Date Function - YouTube
  7. C Date im Test Die Bedienung von C Date - YouTube
  8. Date Picker Control - Excel VBA Data Entry Userform (Part ...

This tutorial explains Date in VBA programming. We can add days or remove days from current date using Date function in VBA Code. Excel VBA UserForm TextBox - Learn how to format date The code used in this video: Private Sub UserForm_Initialize() 'txtDate.Text = Format(Now(), 'Short Dat... I show you how to add a date picker (calendar) control to a our VBA userform for data entry in excel 2016. These calendar controls are so nice for quickly se... C Date ist eine Casual Dating Partnervermittlung. Wir von 100Singlebörsen haben C-Date getestet und auf Herz und Nieren überprüft. Mehr gibt es unter: http:/... In this video, you will learn how to use Date, CDate, DateAdd function in Excel VBA. This video will answer following queries: Excel VBA - Dates Date functio... VBA - Funções de Data (CDate, IsDate, Year, Month, Day) Tomas Vasquez. Loading... Unsubscribe from Tomas Vasquez? Cancel Unsubscribe. Working... Subscribe Subscribed Unsubscribe 7.51K. dte = CDate(mbox) Range('C9') = dte Else MsgBox 'This isn't a date. Try Again' End If End Sub. ... Excel VBA USERFORMS #25 Date Picker Calendar revealed! How to use date format functions in Excel user-form and perform calculations like finding difference in days using the datediff function. Details available a...