With the below code, I am able to create a copy of excel but I want to move the particular file from one location to another location. Please advise as to what all changes are require in below code.
myFileNameDir = Sheet1.Range("V4").Value & TextBox38.Text & ".xlsx"
Workbooks.Open Filename:=myFileNameDir, UpdateLinks:=0
Set ws1 = Worksheets("sheet1")
ws1.Activate
ws1.SaveAs Sheet1.Range("V3").Value & TextBox3.Text & ".xlsx"
Try:
ws1.SaveAs "C:\yourpath\" & Sheet1.Range("V3").Value & TextBox3.Text & ".xlsm"
This code will move your file without having to open it:
Sub test()
Dim mySourceFileName As String
Dim myTargetFileName As String
mySourceFileName = Sheet1.Range("V4").Value & TextBox38.Text & ".xlsx"
myTargetFileName = Sheet1.Range("V3").Value & TextBox3.Text & ".xlsx"
MsgBox "File Copied:" & CopyFile(mySourceFileName, myTargetFileName, True), vbOKOnly
End Sub
Function CopyFile(FromFile As String, ToFile As String, Overwrite As Boolean) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
oFSO.CopyFile FromFile, ToFile, Overwrite
CopyFile = (Err.Number = 0)
Err.Clear
End Function
To move the file use:
Sub test()
Dim mySourceFileName As String
Dim myTargetFileName As String
mySourceFileName = Sheet1.Range("V4").Value & TextBox38.Text & ".xlsx"
myTargetFileName = Sheet1.Range("V3").Value & TextBox3.Text & ".xlsx"
MsgBox "File Moved:" & MoveFile(mySourceFileName, myTargetFileName), vbOKOnly
End Sub
Public Function MoveFile(FromFile As String, ToFile As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
oFSO.MoveFile FromFile, ToFile
MoveFile = (Err.Number = 0)
Err.Clear
End Function
Related
I have this code that exports a worksheet to the desktop. I want to change the formulas to values but only in the exported file, but I don't know how to do it.
Thanks.
Sub ExportWorksheets()
Dim worksheet_list As Variant, worksheet_name As Variant
Dim new_workbook As Workbook
Dim saved_folder As String
Dim File_name As String
Dim New_File_Name As String
worksheet_list = Array("Sheet_02")
'// makes sure you close the path with a back slash \
saved_folder = Environ("userprofile") & "\Desktop\"
For Each worksheet_name In worksheet_list
On Error Resume Next
' Opens a new Excel wokrobook
Set new_workbook = Workbooks.Add
File_name = ThisWorkbook.Name
File_name_02 = Replace(File_name, ".xlsm", "")
New_File_Name = worksheet_name & "_" & File_name_02 & ".xlsx"
ThisWorkbook.Worksheets(worksheet_name).Copy new_workbook.Worksheets(1)
new_workbook.SaveAs saved_folder & New_File_Name, 51
new_workbook.Close False
Next worksheet_name
MsgBox "Export completed. " & New_File_Name, vbInformation
End Sub
Please, try the next updated code. You do not need to previously create a new workbook, and .Value = .Value does what you need:
Sub ExportWorksheets()
Dim worksheet_list As Variant, worksheet_name As Variant
Dim saved_folder As String, File_name As String, New_File_Name As String
worksheet_list = Array("Sheet_02")
'// makes sure you close the path with a back slash \
saved_folder = Environ("userprofile") & "\Desktop\"
For Each worksheet_name In worksheet_list
File_name = ThisWorkbook.name
File_name_02 = Replace(File_name, ".xlsm", "")
New_File_Name = worksheet_name & "_" & File_name_02 & ".xlsx"
ThisWorkbook.Worksheets(worksheet_name).Copy 'it automatically create a new workbook with the content of the respective sheet
With ActiveWorkbook.Sheets(1).UsedRange
.value2 = .value2 'value2 is faster and may be used since the range has the same format...
End With
ActiveWorkbook.saveas saved_folder & New_File_Name, 51
ActiveWorkbook.Close False
Next worksheet_name
MsgBox "Export completed. " & New_File_Name, vbInformation
End Sub
I inherited VBA code that has not worked since my work updated our version of Excel.
The original code looped through all Excel files in a specific folder.
If data in specific cells was blank or a 0, would rename the whole workbook so I would know what files to delete after the fact.
This is the original code. I don't need it to do all of this anymore.
This is part one:
Sub AllFilesWeekly()
Dim folderPath As String
Dim filename As String
Dim wb As Workbook
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & filename)
'Call a subroutine here to operate on the just-opened workbook
Call getmetrics
On Error Resume Next
If Not ActiveWorkbook.Name Like "Audit Hub Report Distribution*" Then
ActiveWorkbook.Close
End If
filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
The second part:
Sub getmetrics()
Dim cell As Range
Dim procstring As String, wbname As String
'Dim OQAYTD As String
Dim OQAMTD As String
Dim ORLYTD As String
Dim ORLMTD As String
Dim DR As String
Dim Audits As Long
Dim permonth As String, peryear As String, permonthrl As String, peryearrl As String
Dim RS As Worksheet, AD As Worksheet, QD As Worksheet, ws As Worksheet, YN As Boolean
For Each ws In Worksheets
If ws.Name = "Audit Detail" Then
YN = True
End If
Next ws
If YN = True Then
ActiveWorkbook.Sheets(2).Name = ("Rep Summary")
Set RS = ActiveWorkbook.Sheets("Rep Summary")
Set AD = ActiveWorkbook.Sheets("Audit Detail")
Set QD = ActiveWorkbook.Sheets("Question Detail")
With Sheets("Process Summary")
For Each cell In Range(Range("A3"), Range("A9999").End(xlUp))
If cell.Value = "Record Level YTD" Then
ORLYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "YTD Quality Average" Then
OQAYTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Record Level Quality Average" Then
ORLMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Quality Average" Then
OQAMTD = Range(cell.Address).Offset(0, 1).Value
Else
If cell.Value = "Audits" Then
Audits = Range(cell.Address).Offset(0, 1).Value
End If
End If
End If
End If
End If
Next cell
End With
wbname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4)
peryear = VBA.Format(OQAYTD, "Percent")
permonth = VBA.Format(OQAMTD, "Percent")
peryearrl = VBA.Format(ORLYTD, "Percent")
permonthrl = VBA.Format(ORLMTD, "Percent")
DR = Right(Sheets("Process Summary").Range("A2").Value, Len(Sheets("Process
Summary").Range("A2").Value) - 12)
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).AutoFilter
RS.Range(RS.Range("A1"), RS.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).AutoFilter
AD.Range(AD.Range("A1"), AD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).AutoFilter
QD.Range(QD.Range("A1"), QD.Range("IV1").End(xlToLeft)).EntireColumn.AutoFit
Application.DisplayAlerts = False
procstring = wbname & "|" & permonth & "|" & Audits & "|" & peryear & "|" & permonthrl & "|" &
peryearrl & "|" & DR ' & "|" & Users
Debug.Print procstring
Else
Application.DisplayAlerts = False
Dim AWN As String
AWN = ActiveWorkbook.FullName
Debug.Print "Not Audited: " & ActiveWorkbook.Name
ActiveWorkbook.SaveAs "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\Delete -" & Second(Now)
Kill AWN
ActiveWorkbook.Close savechanges:=True
Application.DisplayAlerts = True
End If
End Sub
All I need to do is look at cell D3 on the "Process Summary" tab.
If the value in that space is "0.00%", rename the workbook to delete and loop on until all workbooks are looked at.
I do not need to screen print all the extra numbers any more.
Build a Collection of filenames that match the criteria and then use it to rename the files.
Option Explicit
Sub AllFilesWeekly()
Dim folderPath As String, filename As String
Dim wb As Workbook, ws As Worksheet
Dim col As Collection, n As Long
Set col = New Collection
folderPath = "C:\Users\" & (Environ$("Username")) & "\Desktop\Process Production\" 'change to suit
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
' scan folder
filename = Dir(folderPath & "*.xlsx")
Do While filename <> ""
Set wb = Workbooks.Open(folderPath & filename, True, True) ' update links, readonly
For Each ws In wb.Sheets
If ws.Name = "Process Summary" Then
If Format(ws.Range("D3"), "0.00%") = "0.00%" Then
col.Add wb.Name
End If
End If
Next
wb.Close
n = n + 1
filename = Dir
Loop
' result
MsgBox "Files scanned = " & n & vbCrLf & _
"To delete = " & col.Count, vbInformation, folderPath
' rename
If col.Count > 0 Then
If MsgBox("Continue to rename ?", vbYesNo) = vbYes Then
For n = 1 To col.Count
Name folderPath & col(n) As folderPath & "delete_" & col(n)
Next
MsgBox "Rename done"
End If
End If
End Sub
I want to save Excel files in both the local drive and in the network folder. Currently I am doing it with SaveAs (local) and another SaveAs (network), is it faster to do a SaveAs then FileCopy?
Code below:
Sub SaveAs()
Dim ws As Worksheet
Dim ws_console As Worksheet
Dim long_col_number As Long
Dim long_sheets_count As Long
Dim arr_sheet_names As Variant
Dim str_password As String
Dim str_datetoday As String
Dim str_datetoday_path As String
Dim str_datetoday_network_path As String
str_datetoday = Format(Date, "yyyy-mm-dd")
str_datetoday_path = "C:\Users\" & Environ("Username") & "\Desktop\Report\" & str_datetoday
str_datetoday_network_path = "\\servername\data\reports\US Reports Daily\" & str_datetoday
If Dir(str_datetoday_path, vbDirectory) = "" Then
MkDir (str_datetoday_path)
MsgBox "Making directory"
End If
If Dir(str_datetoday_network_path, vbDirectory) = "" Then
MkDir (str_datetoday_network_path)
End If
For Each ws In ThisWorkbook.Worksheets
If ws.CodeName = "AILD_01_Console" Then
Set ws_console = ws
Exit For
End If
Next ws
long_col_number = 0
For long_col_number = 1 To 8
long_sheets_count = Application.WorksheetFunction.CountA(ws_console.Range(Cells(16, long_col_number), Cells(24, long_col_number)))
arr_sheet_names = ws_console.Range(Cells(16, long_col_number), Cells(15 + long_sheets_count, long_col_number))
arr_sheet_names = Application.WorksheetFunction.Transpose(arr_sheet_names)
Worksheets(arr_sheet_names).Copy
ActiveWorkbook.SaveAs _
Filename:=str_datetoday_path & "\" & ws_console.Cells(15, long_col_number) & " - " & Format(Date, "yyyy-mm-dd"), _
FileFormat:=51
ActiveWorkbook.SaveAs _
Filename:=str_datetoday_network_path & "\" & ws_console.Cells(15, long_col_number), _
FileFormat:=51
ActiveWorkbook.Close False
Next long_col_number
ws_console.Activate
End Sub
Thank you very much for all the help.
How to copy the entire worksheet from a workbook and save it as new workbook to a specific directory with the customized filename(I am trying to pick the filename from on of the cells in the worksheet. The sheet that I need to copy has few merged cells too.
Sub CopyItOver()
Dim fname As String
Dim fpath As String
Dim NewBook As Workbook
Dim name as String
fpath = "C:\Users\..\"
fname = "List" & name & ".xlsm"
name = Range("c3").Value
Set NewBook = Workbooks.Add
ActiveWorkbook.Sheets("Generator").Copy Before:=NewBook.Sheets(1)
If Dir(fpath & "\" & fname) <> "" Then
MsgBox "File " & fpath & "\" & fname & " already exists"
Else
NewBook.SaveAs FileName:=fpath & "\" & fname
End If
End Sub
When I run this it, give me Subscript out of range error in this line
ActiveWorkbook.Sheets("Generator").Copy Before:=NewBook.Sheets(1)
Suggest you try it like this:
Check to see if Generator exists before progressing
If you use .Copy then the worksheet is automatically copied to a new workbook (so you don't need to add a new book first)
code
Sub CopyItOver()
Dim fname As String
Dim fpath As String
Dim name As String
Dim ws As Worksheet
fpath = "C:\Users\..\"
fname = "List" & name & ".xlsm"
name = Range("c3").Value
On Error Resume Next
Set ws = ThisWorkbook.Sheets("Generator")
On Error GoTo 0
If ws Is Nothing Then
MsgBox "sheet doesn't exist"
Exit Sub
End If
If Dir(fpath & "\" & fname) = vbNullString Then
ThisWorkbook.Sheets("Generator").Copy
ActiveWorkbook.SaveAs Filename:=fpath & "\" & fname
Else
MsgBox "File " & fpath & "\" & fname & " already exists"
End If
End Sub
When entering data into a .txt to act as a log, it does get quite large, several MB, and the generic txt reader for MS will have a conniption. Is there a way to put a log into a folder that may or may not exist? So in other words, if a folder doesn't exist, create folder, and cut and paste old log into new folder?
Since I know there will be possibilities for multiple logs to be in said log folder, would there be a way to make it so that there is today's date attached to the log name as well?
Think I solved it...
If FileLen(sLogFileName) > 3145728# Then
sLogFileName = "Open Order Log - " & Format(Date, "dd-mm-yyyy")
Name sLogFileName As "ThisWorkbook.path & Application.PathSeparator & \Temp\Open Order Log - " & Format(Date, "dd-mm-yyyy")
End If
From your other question, it is obvious that you know how to create a log file.
And from your above question, I could summarize that this is your query
Check if a folder exists or not
Creating a Folder
Add Date to a log file's name
Checking the file Size
Moving a File
So let's take them one by one.
Check if a folder exists or not. You can use the DIR function to check for that. See example below
Public Function DoesFolderExist(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString Then _
DoesFolderExist = True
Whoa:
On Error GoTo 0
End Function
Regarding your next query, you can use MKDIR to create a folder. See this example
Sub Sample()
MkDir "C:\Sample"
End Sub
Regarding the third query, you can create a log file with a date appended to it like this
Sub Sample()
Dim FlName As String
FlName = "Sample File - " & Format(Date, "dd-mm-yyyy")
Debug.Print FlName
End Sub
To check for a file size, you can use the FileLen function. See this example
Sub Sample()
Dim FileNM As String
FileNM = "C:\Sample.txt"
Debug.Print "The File size of " & FileNM & " is " & _
FileLen(FileNM) & " bytes"
End Sub
And to move a file from one directory to the other you can use the NAME function. See this example.
Sub Sample()
Dim FileNM As String
FileNM = "C:\Sample.txt"
Name FileNM As "C:\Temp\Sample.txt"
End Sub
So now you can put all of these together to achieve what you want :)
FOLLOWUP (FROM CHAT)
This is what we finally arrived at
Option Explicit
Dim PreviousValue
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
PreviousValue = Target(1).Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sLogFileName As String, ArchiveFileName As String
Dim ArchFolder As String, sLogMessage As String
Dim nFileNum As Long
Dim NewVal
On Error GoTo Whoa
Application.EnableEvents = False
sLogFileName = ThisWorkbook.path & Application.PathSeparator & _
"Open Order Log.txt"
If Not Target.Cells.Count > 1 Then
If Target.Value <> PreviousValue Then
'~~> Check if the Log File exists
If DoesFileFldrExist(sLogFileName) = True Then
'~~> Check for the File Size
If FileLen(sLogFileName) > 3145728 Then
'~~> Check if the "Log History" folder exists
ArchFolder = ThisWorkbook.path & _
Application.PathSeparator & "Log History"
'~~> If the "Log History" folder doesn't exist, then create it
If DoesFileFldrExist(ArchFolder) = False Then
MkDir ArchFolder
End If
'~~> Generate a new file name for the archive file
ArchiveFileName = ArchFolder & Application.PathSeparator & _
"Open Order Log - " & Format(Date, "dd-mm-yyyy") & ".txt"
'~~> Move the file
Name sLogFileName As ArchiveFileName
End If
End If
'~~> Check if the cell is blank or not
If Len(Trim(Target.Value)) = 0 Then _
NewVal = "Blank" Else NewVal = Target.Value
sLogMessage = Now & Application.UserName & _
" changed cell " & Target.Address & " from " & _
PreviousValue & " to " & NewVal
nFileNum = FreeFile
'~~> If the log file exists then append to it else create
'~~> a new output file
If DoesFileFldrExist(sLogFileName) = True Then
Open sLogFileName For Append As #nFileNum
Else
Open sLogFileName For Output As #nFileNum
End If
Print #nFileNum, sLogMessage
Close #nFileNum
End If
End If
LetsContinue:
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Public Function DoesFileFldrExist(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString _
Then DoesFileFldrExist = True
Whoa:
On Error GoTo 0
End Function
Sub MoveFiles()
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Dim MyFile As String
Inlocation = ws.Range("A1").Value & "\"
Lastdate = Format(ws.Range("A3").Value, "DD-MM-YYYY")
Outlocation = ws.Range("A2").Value
Foulocation = Outlocation & "\" & Lastdate
MyFile = Dir(Inlocation & "*.*")
Set oFSO = CreateObject("Scripting.FileSystemObject")
'Check Specified Folder exists or not
If Not oFSO.FolderExists(Foulocation) Then
'If Folder is available
MkDir Foulocation
End If
Do Until MyFile = ""
oFSO.CopyFile Inlocation & MyFile, Foulocation & "\", True
If Inlocation <> Foulocation Then
oFSO.DeleteFile Inlocation & MyFile
End If
'Name Inlocation & MyFile As Foulocation & "\" & MyFile
MyFile = Dir
Loop
MsgBox "Files successfully moved to location " & Foulocation
End Sub