I have a form a text box to enter the Month and year in this format Dec-15, but it actually returns the value 15/12/2016 in the VBA code.
How can I make it 01/12/2015?
sMonthYear = Trim(Form.txtMonthYear.Value)
report heading = Dec-15
Sheets("Report").Cells(2, 2).Value = "" & sMonthYear & ""
find Folder = 2015
sFolderYear = Year(sMonthYear)
strSavePath = sFilePath + sFolderYear + "\"
File name = Dec-15
sFileName = sMonthYear
wbDest.SaveAs strSavePath & sFileName & ".xls"
Thanks
Try this...
Sheets("Sheet1").Cells(2, 2).Value = "01" & "" & sMonthYear & ""
Or Format The Cell
Option Explicit
Sub DateFormat()
Dim sMonthYear As String
sMonthYear = "Dec-15"
Sheets("Sheet1").Cells(2, 2).NumberFormat = "DD/MM/YYYY"
Sheets("Sheet1").Cells(2, 2).Value = "01" & "" & sMonthYear & ""
End Sub
Related
I have two workbooks one "database" and another "source". What I'm trying to achieve is to set up a loop that would iterate thru a known range in "source" wb and create links in "database". Data in the "source" wb = C7:C38.
Any ideas?
Code below is the one i'm using to pull single values for the links - how can I make it loop thru range C7:C38?
Option Explicit
'**********Using ip address to link/locate folders in the the directory.
Public Sub PullData()
Dim repDate As Date
Dim tmpFileStr As String
Dim tmpPathStr As String
Dim rowCtrLng As Long
Dim startRowCtrLng As Long
Dim stoptRowCtrLng As Long
Dim msgStr As String
Dim currentDate As Date
Dim stopDate
Dim fldName As String
Dim fName As String
Dim fDay As String
'On Error GoTo errHandler
'Initialize row counter
startRowCtrLng = 2
'Get starting row for new data
Do While ThisWorkbook.ActiveSheet.Range("B" & startRowCtrLng).Value <> ""
startRowCtrLng = startRowCtrLng + 1
Loop
rowCtrLng = startRowCtrLng
'Assign current date to variable
'Pause automatic calculation
Application.Calculation = xlCalculationManual
'Disable alerts
Application.DisplayAlerts = False
repDate = Format(ThisWorkbook.Worksheets("Database").Range("A" & rowCtrLng).Value, "mm/dd/yyyy")
currentDate = Date
fldName = Format(Year(Now), "0000")
fName = Format(Month(Now), "00")
fDay = Format(Day(Now), "0")
'Begin looping through date range
Do While repDate < currentDate
tmpFileStr = ""
tmpPathStr = ""
'Determine if report exists
tmpPathStr = "\\0.0.0.0\dept\Folder\Subfolder\" & fldName & "\"
If Dir("\\0.0.0.0\dept\Folder\Subfolder\" & fldName & "\" & fName & "-" & fldName & ".xls") <> "" Then
tmpFileStr = fName & "-" & fldName & ".xls"
Else
tmpFileStr = ""
End If
If tmpFileStr <> "" Then
'build Links
'Production Date
ThisWorkbook.ActiveSheet.Range("A" & rowCtrLng).Value = repDate
'Crush
ThisWorkbook.ActiveSheet.Range("B" & rowCtrLng).Value = "='" & tmpPathStr & "[" & tmpFileStr & "]C vol'!$C$7"
End If
rowCtrLng = rowCtrLng + 1
repDate = ThisWorkbook.Worksheets("Database").Range("A" & rowCtrLng).Value
Loop
End Sub
'
Please note I am not a regular programmer, I have sufficient understanding of coding. I am making a form in which ComboBox1 gives Month, ComboBox2 gives starting date, Combobox3 given ending date.
In the code below, arraystr1 should have values in format - 2, "10/4/2015", 2, "10/5/2015", 2, "10/6/2015", 2, "10/7/2015"
Now my arraystr1 is giving me the values in same format but when I am running the program, its giving me error - "AutoFilter method of Range class falied"
Dim Z As Long
Dim cbstr1 As String
Dim cbstr2 As String
Dim cbstr3 As String
Dim cbstr4 As String
Dim datestr1 As String
Dim datestr2 As String
Dim arraystr1 As String
Dim arraystr2 As String
Dim arraystr3 As String
Dim partstr1 As String
Dim partstr2 As String
partstr1 = " 2,"
partstr2 = ","
arraystr3 = ""
Select Case (ComboBox1.Text)
Case "January"
cbstr2 = "01"
//............//
Case "December"
cbstr2 = "12"
End Select
cbstr3 = ComboBox2.Text
cbstr4 = ComboBox3.Text
datestr1 = cbstr2 & "/" & cbstr3 & "/2015"
datestr2 = cbstr2 & "/" & cbstr4 & "/2015"
If cbstr3 = cbstr4 Then
arraystr1 = partstr1 & Chr(34) & datestr1 & Chr(34)
Else
For Z = cbstr3 To cbstr4
If Z = cbstr4 Then
**arraystr1** = arraystr3 & partstr1 & Chr(34) & datestr2 & Chr(34)
Else
arraystr2 = cbstr2 & "/" & Z & "/2015"
arraystr3 = partstr1 & Chr(34) & arraystr2 & Chr(34) & partstr2
End If
Next Z
End If
MsgBox (arraystr1)
Sheets("Sheet13").UsedRange.ClearContents
Sheets("Full data").Range("$A$1:$AB$45107").AutoFilter Field:=14, Operator:= _
xlFilterValues, Criteria2:=Array(**arraystr1**)
Selection.SpecialCells(xlCellTypeVisible).Select
Sheets("Full data").Select
Range("F:F,L:L,N:N,Q:Q,S:S").Select
Selection.Copy
Sheets("Sheet13").Select
Sheets("Sheet13").Cells(1, 1).Select
Sheets("Sheet13").Paste
Sheets("Sheet13").Range("C:C,E:E").Select
Application.CutCopyMode = False
Selection.NumberFormat = "General"
I'm trying to develop a macro on one of my spreadsheets that will take the value of Column B (2502-13892-33 for example), starting at Row 3, and search the source folder listed in column A for that file (using Wildcards before and after the value in column B. Once it finds that file, it needs to use FileCopy to copy the file into the Destination Folder listed in Column C, but only after renaming the file in the form of "Column E"_"Original Filename (A252_2502-13892-33 for example).
I think I have worked out the code to make this work because when I tested it, it functioned exactly like I expected it to, found the file, copied it to the new destination with the PREFIX from column E and the underscore added to the filename. The problem is that it just stops after the first file, which leads me to believe something is wrong with the structure of my loop.
My code is as follows:
Sub MoveFiles()
Dim SourcePath As String
Dim DestPath As String
Dim PartNum As String
Dim PLISN As String
Dim LastRow As Long
Dim i As Long
Dim filename As String
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
PLISN = Cells(i, "E").Value
PartNum = Cells(i, "B").Value
If Right(Cells(i, "A").Value, 1) <> Application.PathSeparator Then
SourcePath = Cells(i, "A").Value & Application.PathSeparator
Else
SourcePath = Cells(i, "A").Value
End If
If Right(Cells(i, "C").Value, 1) <> Application.PathSeparator Then
DestPath = Cells(i, "C").Value & Application.PathSeparator
Else
DestPath = Cells(i, "C").Value
End If
If Dir$(SourcePath & "*" & PartNum & "*") = "" Then
Cells(i, "D").Value = "Source file does not exist."
ElseIf Dir$(DestPath & PLISN & "_" & "*" & PartNum & ".pdf") <> "" Then
Cells(i, "D").Value = "File already exists."
Else
filename = Dir$(SourcePath & "*" & PartNum & "*" & ".pdf")
'Copy the file
FileCopy SourcePath & filename, DestPath & PLISN & "_" & filename
Cells(i, "D").Value = "File Copied to new location"
End If
Next i
End Sub
I had accidentally left my DestinationPath blank for the 2nd and 3rd lines of the excel sheet. That was what was giving me just the "\" as the destination path. Seems to be working properly now.
As someone mentioned below in one of the comments, stepping through my code in the debugger was extremely helpful to solving this problem. My final code has some structural changes, in that I no longer have columns for SourcePath and DestPath, and instead use a folder dialog box to have the user select both of those.
The code for selecting my Source and Destination Folders:
Sub SourceFolder()
Dim lCount As Long
Dim rCount As Long
SourcePath = vbNullString
DestPath = vbNullString
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Title = "Source Path"
.Show
For lCount = 1 To .SelectedItems.Count
SourcePath = .SelectedItems(lCount)
MsgBox (SourcePath)
Next lCount
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = OpenAt
.Title = "Destination Path"
.Show
For rCount = 1 To .SelectedItems.Count
DestPath = .SelectedItems(rCount)
MsgBox (DestPath)
Next rCount
End With
End Sub
The code for actually going out to the SourcePath, searching for the filename located in Column A (including with wildcards before and after), copying it to the DestinationPath, and renaming it with ColumnB's Value, followed by an underscore, and then ColumnA's Value is as follows:
Option Explicit
Public SourcePath As String
Public DestPath As String
Dim PartNum As String
Dim PLISN As String
Sub MoveFiles()
Dim LastRow As Long
Dim i As Long
Dim filename As String
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To LastRow
PLISN = Cells(i, "B").Value
PartNum = Cells(i, "A").Value
If Right(SourcePath, 1) <> Application.PathSeparator Then
SourcePath = SourcePath & Application.PathSeparator
Else
SourcePath = SourcePath
End If
If Right(DestPath, 1) <> Application.PathSeparator Then
DestPath = DestPath & Application.PathSeparator
Else
DestPath = DestPath
End If
If Dir$(SourcePath & "*" & "*" & PartNum & "*") = "" Then
Cells(i, "C").Value = "Source file does not exist."
ElseIf Dir$(DestPath & PLISN & "_" & "*" & PartNum & "*" & ".pdf") <> "" Then
Cells(i, "C").Value = "File already exists."
Else
filename = Dir$(SourcePath & "*" & PartNum & "*" & ".pdf")
'Copy the file
FileCopy SourcePath & filename, DestPath & PLISN & "_" & filename
Cells(i, "C").Value = "File Copied to new location"
End If
Next i
End Sub
I'm looking to write a macro to save my current version filename +1 instance of the version. For each new day the version would reset to v01. Ex. Current = DailySheet_20150221v01; Save As = DailySheet_20150221v02; Next Day = DailySheet_20150222v01
While increasing the version number, I am hoping the version won't have to contain the v0 once v10+ has been reached.
I was able to workout how to save the file with today's date:
Sub CopyDailySheet()
Dim datestr As String
datestr = Format(Now, "yyyymmdd")
ActiveWorkbook.SaveAs "D:\Projects\Daily Sheet\DailySheet_" & datestr & ".xlsx"
End Sub
but need additional help in finding the version addition. Could I set the SaveAs to a string, then run it through a For/If - Then set?
Put this out to a couple of my friends and below is their solution:
Sub Copy_DailySheet()
Dim datestr As String, f As String, CurrentFileDate As String, _
CurrentVersion As String, SaveAsDate As String, SaveAsVersion As String
f = ThisWorkbook.FullName
SaveAsDate = Format(Now, "yyyymmdd")
ary = Split(f, "_")
bry = Split(ary(UBound(ary)), "v")
cry = Split(bry(UBound(bry)), ".")
CurrentFileDate = bry(0)
CurrentVersion = cry(0)
SaveAsDate = Format(Now, "yyyymmdd")
If SaveAsDate = CurrentFileDate Then
SaveAsVersion = CurrentVersion + 1
Else
SaveAsVersion = 1
End If
If SaveAsVersion < 10 Then
ThisWorkbook.SaveAs "D:\Projects\Daily Sheet\DailySheet_" & SaveAsDate & "v0" & SaveAsVersion & ".xlsm"
Else
ThisWorkbook.SaveAs "D:\Projects\Daily Sheet\Daily Sheet_" & SaveAsDate & "v" & SaveAsVersion & ".xlsm"
End If
End Sub
Thanks to all those who contributed.
Try this one:
Sub CopyDailySheet()
'Variables declaration
Dim path As String
Dim sht_nm As String
Dim datestr As String
Dim rev As Integer
Dim chk_fil As Boolean
Dim ws As Object
'Variables initialization
path = "D:\Projects\Daily_Sheet"
sht_nm = "DailySheet"
datestr = Format(Now, "yyyymmdd")
rev = 0
'Create new Windows Shell object
Set ws = CreateObject("Wscript.Shell")
'Check the latest existing revision number
Do
rev = rev + 1
chk_fil = ws.Exec("powershell test-path " & path & "\" & sht_nm & "_" & datestr & "v" & Format(rev, "00") & ".*").StdOut.ReadLine
Loop While chk_fil = True
'Save File with new revision number
ActiveWorkbook.SaveAs path & "\" & sht_nm & "_" & datestr & "v" & Format(rev, "00") & ".xlsm"
End Sub
If you have the current filename I would use something like:
Public Function GetNewFileName(s As String) As String
ary = Split(s, "v")
n = "0" & CStr(CLng(ary(1)) + 1)
GetNewFileName = ary(0) & "v" & ary(1)
End Function
Tested with:
Sub MAIN()
strng = GetNewFileName("DailySheet_20150221v02")
MsgBox strng
End Sub
I have written some Excel VBA code to add the filenames, versions, and last modified date/time to a worksheet. The code appears to work fine, except sometimes the time portion of the Last Modified Date for a file will either be exactly 1 hour forward or backward from what I see in an Explorer window.
I have noticed the values that my code returns is the same as the modified date/time shown in a cmd window if I perform a dir command.
For example, if I look up the dbghelp.dll file in the system32 folder:
C:\Windows\System32>dir dbghelp.*
Volume in drive C has no label.
Volume Serial Number is 16E8-4159
Directory of C:\Windows\System32
21/11/2010 04:24 1,087,488 dbghelp.dll
1 File(s) 1,087,488 bytes
0 Dir(s) 60,439,101,440 bytes free
C:\Windows\System32>
But the same file in an Explorer window shows a modified time of 03:24 on 21/11/2010 - 1 hour earlier.
The code I have written is returning the cmd window time, whereas I want the Explorer window time:
Sub GetFileDetails()
Dim path As String
Dim objFSO As Object
Dim objFile As Object
Dim objFolder As Object
Dim loopCount As Integer
Dim pathCheck As Boolean
'Prompt for directory path
path = InputBox(Prompt:="Enter file path", Title:="Enter file path", Default:="")
If (path = "" Or path = vbNullString) Then
MsgBox ("Invalid path - exiting")
Exit Sub
End If
'Required for interacting with filesystem
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(path)
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
Range("B" & loopCount).Value = objFSO.GetFileVersion(objFile)
Range("C" & loopCount).Value = objFile.DateLastModified
'Combine Version and Modified
If Range("B" & loopCount).Value <> "" Then
Range("D" & loopCount).Value = Range("B" & loopCount).Value & ", " & Range("C" & loopCount).Value
Else
Range("D" & loopCount).Value = Range("C" & loopCount).Value
End If
loopCount = loopCount + 1
Next
'Set up headings
Range("A" & 1).Value = (loopCount - 3) & " files found in " & path
Range("A" & 2).Value = "FileName"
Range("B" & 2).Value = "Version"
Range("C" & 2).Value = "Modified"
Range("D" & 2).Value = "Version & Modified"
End Sub
If anyone can shed some light on this issue - it will be greatly appreciated.
===EDIT===
This is the code I have come up with which always gives me the same time as displayed in an explorer window:
Sub GetFileDetails()
Dim path As String
Dim objFSO As Object
Dim objFile As Object
Dim objFolder As Object
Dim loopCount As Integer
Dim pathCheck As Boolean
Dim modDate As Date
Dim modHour As Integer
Dim modMin As Integer
'Prompt for directory path
path = InputBox(Prompt:="Enter file path", Title:="Enter file path", Default:="")
If (path = "" Or path = vbNullString) Then
MsgBox ("Invalid path - exiting")
Exit Sub
End If
'Required for interacting with filesystem
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(path)
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
Range("B" & loopCount).Value = objFSO.GetFileVersion(objFile)
Range("D" & loopCount).Value = objFile.Name
'The date modified time for files made in Summer Time are correct, whereas Winter Time will be 1 hour forward
If (IsItSummerTime(objFile.DateLastModified) = True) Then
Range("C" & loopCount).Value = objFile.DateLastModified
Else
modDate = Format(objFile.DateLastModified, "DD-MM-YYYY")
modHour = Hour(objFile.DateLastModified)
modMin = Minute(objFile.DateLastModified)
modHour = modHour - 1
If (modHour < 10) Then
If (modMin < 10) Then
Range("C" & loopCount).Value = modDate & " 0" & modHour & ":0" & modMin
Else
Range("C" & loopCount).Value = modDate & " 0" & modHour & ":" & modMin
End If
Else
If (modMin < 10) Then
Range("C" & loopCount).Value = modDate & " " & modHour & ":0" & modMin
Else
Range("C" & loopCount).Value = modDate & " " & modHour & ":" & modMin
End If
End If
End If
'Combine Version and Modified
If Range("B" & loopCount).Value <> "" Then
Range("E" & loopCount).Value = Range("B" & loopCount).Value & ", " & Range("C" & loopCount).Value
Else
Range("E" & loopCount).Value = Range("C" & loopCount).Value
End If
loopCount = loopCount + 1
Next
'Set up headings
Range("A" & 1).Value = (loopCount - 3) & " files found in " & path
Range("A" & 2).Value = "FileName"
Range("B" & 2).Value = "Version"
Range("C" & 2).Value = "Modified"
Range("D" & 2).Value = "FileName"
Range("E" & 2).Value = "Version & Modified"
End Sub
Function IsItSummerTime(inDate As Date) As Boolean
Dim inDateYear As Integer
Dim findFirstSunday As Date
Dim firstSundayDate As Date
Dim startDays As Integer
Dim endDays As Integer
Dim summerStart As Date
Dim summerEnd As Date
'Summer Time starts on the 13th week
'Summer Time ends on the 42nd week
If (IsItALeapYear(inDate) = True) Then
startDays = (12 * 7) + 1
endDays = (42 * 7) + 1
Else
startDays = 12 * 7
endDays = 42 * 7
End If
'Find the date of the first Sunday in the year
inDateYear = Year(inDate)
For i = 1 To 7
findFirstSunday = DateSerial(inDateYear, 1, i)
If (Weekday(findFirstSunday) = 1) Then
firstSundayDate = findFirstSunday
End If
Next i
'Calculate the start and end dates for Summer Time
summerStart = firstSundayDate + startDays
summerEnd = firstSundayDate + endDays
'Compare inDate to Summer Time values and return boolean value
If (inDate >= summerStart And inDate < summerEnd) Then
IsItSummerTime = True
Else
IsItSummerTime = False
End If
End Function
Function IsItALeapYear(inDate As Date) As Boolean
If (Month(DateSerial(Year(inDate), 2, 29))) = 2 Then
IsItALeapYear = True
Else
IsItALeapYear = False
End If
End Function
It looks like this is ultimately an OS issue that you'd have to work around, like has been shown, especially since you've edited your code to account for DST.
But you could also use the FileDateTime function. The help article for this points out that the result of this function is based on your system's locale settings. The help article for the DateLastModified property doesn't provide any such caveats, at least for Excel online help.
To modify an exerpt from your edited code above:
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
'use the full path name
Range("B" & loopCount).Value = FileDateTime(objFile_fullpathname)
Range("D" & loopCount).Value = objFile.Name