Hi I have drafted the below code, which use the DIR function to loop through all the files and rename them, however this is not carried out in alphabetical order
Can the below code be amended to ensure it is completed in alphabetical order.
Sub Rename_Files()
Dim name As String
Dim returnaname As String
returnName = ActiveWorkbook.name
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Application.EnableEvents = False
'On Error Resume Next
MyFolder = "G:\Corpdata\STRAT_Information\Open\1. Yot Data (Scoring)\34. Disproportionality Tool\201718 Tool\Local Level Tool\Database_Extract_Tools\Area Files Offences"
MyFile = Dir(MyFolder & "\*.xls")
Do While MyFile <> ""
Workbooks.Open Filename:=MyFolder & "\" & MyFile
name = Left(ActiveWorkbook.name, Len(ActiveWorkbook.name) - 5)
name = name & ("_Offence")
ActiveWorkbook.SaveAs Filename:=name
Windows(returnName).Activate
MyFile = Dir$ 'goes to next entry
Loop
End Sub
Related
I need to write a macro that allows me to select which workbook sheets I want to save as a new file separately.
I am currently doing it with the following code, but it saves all the sheets as a new file. I would like to be able to select or define which sheets I want to save.
Sub Save_sheets_xlsx()
Dim Path As String
Path = Application.ActiveWorkbook.Path
Dim FileName As String
FileName = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs FileName:=Path & "\" & FileName & " " & xWs.Name & ".xlsx"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Export Sheets As New Workbooks
Option Explicit
Sub ExportSheets()
Const SheetNameList As String = "Sheet1,Sheet2,Sheet3" ' commas no spaces!
Dim SheetNames() As String: SheetNames = Split(SheetNameList, ",")
Dim FolderPath As String: FolderPath = ThisWorkbook.Path
Dim BaseName As String
BaseName = Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 5)
Application.ScreenUpdating = False
Dim sh As Object
Dim FilePath As String
For Each sh In ThisWorkbook.Sheets(SheetNames)
sh.Copy
FilePath = FolderPath & "\" & BaseName & " " & sh.Name & ".xlsx"
Application.DisplayAlerts = False ' overwrite without confirmation
Workbooks(Workbooks.Count).SaveAs FileName:=FilePath
Application.DisplayAlerts = True
Application.ActiveWorkbook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
MsgBox "Sheets exported.", vbInformation
End Sub
I would like to open a workbook using a wildcard or partial name match and save a copy with another name.
However, there is an error -
Always at the " Workbooks(myFolderPath & "" & MyFileName).SaveCopyAs Filename:="NEW NAME.xlsx" " line
Here is my code:
Sub GENERATE()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'If workbook name like "Report Due" then open, if not already opened
Dim MyFileName As Variant
Dim myFolderPath As String
myFolderPath = Application.DefaultFilePath
MyFileName = Dir(myFolderPath & "\" & "Report Due*.xlsx")
If MyFileName <> "" Then
Workbooks.Open (myFolderPath & "\" & MyFileName)
End If
Workbooks(myFolderPath & "\" & MyFileName).SaveCopyAs Filename:="NEW NAME.xlsx"
Workbooks(myFolderPath & "\" & MyFileName).Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I'd be happy to see what's wrong! Many thanks!
Set a reference to the workbook when you open it, then you shouldn't need to use it's name to reference when saving the copy.
Option Explicit
Sub GENERATE()
Dim wb As Workbook
Dim MyFileName As Variant
Dim myFolderPath As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'If workbook name like "Report Due" then open, if not already opened
myFolderPath = Application.DefaultFilePath
MyFileName = Dir(myFolderPath & "\" & "Report Due*.xlsx")
If MyFileName <> "" Then
Set wb = Workbooks.Open(myFolderPath & "\" & MyFileName)
wb.SaveCopyAs Filename:="NEW NAME.xlsx"
wb.Close SaveChanges:=False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I have a bit of code that loops through a bunch of files in a folder, runs a macro on each of them, and then saves them as a .csv file in a different folder. The process runs fine with if the destination csv folder is empty. What I want to do is skip the process if the .csv file already exists. The problem with the code below, is that the Filename = Dir() returns a null value and the loop ends if the .csv file exists. So how do I continue looping through the other files in the first folder?
Sub ProcessFiles()
Dim Filename, Pathname, strFileExists As String
Dim wb As Workbook
Application.ScreenUpdating = False
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
length = Len(ActiveWorkbook.Name)
Name = Left(ActiveWorkbook.Name, length - 5)
CSVName = ActiveWorkbook.Path & "\CSV Files\" & Name & ".csv"
strFileExists = Dir(CSVName)
If strFileExists = "" Then
Transform wb 'Run Transform function
wb.SaveAs Filename:=CSVName, FileFormat:=xlCSVMSDOS, CreateBackup:=False
wb.Close SaveChanges:=False
Filename = Dir()
Else
wb.Close SaveChanges:=False
Filename = Dir()
End If
Loop
End Sub
I think braX is right: the problem is you are using Dir twice. This seems to be working for me:
Sub ProcessFiles()
Dim Filename, Pathname, strFileExists As String
Dim wb As Workbook
Dim IntFileNumber As Integer
Dim IntCounter01 As Integer
Dim Length As Byte
Dim Name As String
Dim CSVName As String
Application.ScreenUpdating = False
Pathname = ActiveWorkbook.Path & "\Files\"
Filename = Dir(Pathname & "*.xlsx")
Do While Filename <> ""
Set wb = Workbooks.Open(Pathname & Filename)
Length = Len(ActiveWorkbook.Name)
Name = Left(ActiveWorkbook.Name, Length - 5)
CSVName = ActiveWorkbook.Path & "\CSV Files\" & Name & ".csv"
strFileExists = Dir(CSVName)
If strFileExists = "" Then
Transform wb 'Run Transform function
wb.SaveAs Filename:=CSVName, FileFormat:=xlCSVMSDOS, CreateBackup:=False
wb.Close SaveChanges:=False
Filename = Dir(Pathname & "*.xlsx")
IntFileNumber = IntFileNumber + 1
For IntCounter01 = 1 To IntFileNumber
Filename = Dir()
Next
Else
wb.Close SaveChanges:=False
Filename = Dir(Pathname & "*.xlsx")
IntFileNumber = IntFileNumber + 1
For IntCounter01 = 1 To IntFileNumber
Filename = Dir()
Next
End If
Loop
End Sub
Basically i reset the Filename and re-play Dir as many time as needed to reach the wanted file.
I've added some declarations too. You might also want to turn true the ScreenUpdating at the end of the subroutine, but that's up to you.
I'm searching for a code to run the same macro on 200+ files in the same folder directory until the last file is complete.
The macro I have currently does this once I click a button
Refresh .CSV data connection (File Selection window pops up in
the directory, I select the file)
Refreshes Pivot Table
Deletes Specific Tabs
Saves Copy As in another Directory
I want to eliminate me clicking the RUN button 200+ times, and selecting the .CSV file. Would anyone happen to know of a code that could do this?
Current MACRO is:
Sub Load_Brand3()
' Load_Brand3 Macro
Sheets("Data").Select
Range("DATATable[[#Headers],[Datetime]]").Select
Selection.ListObject.TableObject.Refresh
Sheets("Brand Summary").Select
Range("A13").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
ActiveSheet.PivotTables("PivotTable1").PivotFields("Retailer.Name").ShowDetail _
= False
Sheets("Brand Summary").Select
Dim SavedCopy As Excel.Workbook
ActiveWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Workbooks.Open "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = ActiveWorkbook
With SavedCopy
ActiveWorkbook.Connections("BrandExport").Delete
Application.DisplayAlerts = False
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Sheets("Brand Summary").Select
Range("A1").Select
Application.DisplayAlerts = True
.Close True
End With
MsgBox ("Your File was saved.")
End Sub
This should be close. Just change MyPath to the correct directory and run ProcessFiles.
Sub ProcessFiles()
Const MyPath As String = "C:\Users\best buy\Data Files\*.csv"
Dim FileName As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
FileName = Dir(MyPath, vbDirectory)
Do While FileName <> ""
Load_BrandFile FileName
FileName = Dir()
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
Sub Load_BrandFile(FileName As String)
Dim SavedCopy As Workbook
Dim DATATable As ListObject
Dim PivotTable1 As PivotTable
ThisWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = Workbooks.Open("C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm")
With SavedCopy
Set DATATable = .Worksheets("Data").ListObjects("DATATable")
DATATable.Refresh
Set PivotTable1 = .Worksheets("Brand Summary").PivotTables("PivotTable1")
PivotTable1.PivotCache.Connection = FileName
PivotTable1.PivotFields("Retailer.Name").ShowDetail = False
.Connections("BrandExport").Delete
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Application.Goto Reference:=.Worksheets("Brand Summary").Range("A1"), scroll:=True
.Close True
End With
End Sub
Hopefully this sorts it for you.
Sub CycleFolder()
Dim folderSelect As FileDialog
Set folderSelect = Application.FileDialog(msoFileDialogFolderPicker)
With folderSelect
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
strItem = .SelectedItems(1)
End With
Files = Dir(strItem & "\")
While Files <> ""
'RUN FUNCTION HERE
'Uncomment next line to test iteration
'Debug.Print Files
Files = Dir
Wend
End Sub
I'm trying to figure out how to import text files (always named tracks.txt) from different folders into one workbook with separate worksheets named after the folder.
basically it should work like this:
select main folder
select multiple sub-folders (which contain the tracks.txt)
or
search in all sub-folders starting with the string (user input)
import tracks.txt in new worksheet
replace worksheetname with subfoldername
would this be possible?
'//-----------------------------------------------------------------------------------------\\
'||code was made with the great help of bsalv and especially snb from www.worksheet.nl ||
'||adjusted and supplemented for original question by myself martijndg (www.worksheet.nl) ||
'\\-----------------------------------------------------------------------------------------//
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select folder with subfolder (containing tracks.txt) NO SPACES IN FILEPATH!!!"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1) + "\" 'laatste slash toegevoegd aan adres
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Sub importtracks()
Dim subfolder, serie As String
c00 = GetFolder("C:\")
serie = InputBox(Prompt:="partial foldername of serie", _
Title:="find folders of 1 serie", Default:="track##.")
If serie = "track##." Or serie = vbNullString Then
Exit Sub
End If
Workbooks.Add
For Each it In Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & c00 & "tracks.txt /b /s").stdout.readall, vbCrLf), ":")
sn = Split(CreateObject("scripting.filesystemobject").opentextfile(it).readall, vbCrLf)
With Sheets
subfolder = Replace(Replace(CreateObject("scripting.filesystemobject").GetParentFolderName(it), "" & c00 & "", ""), "\", "")
End With
If InStr(1, subfolder, serie, vbTextCompare) Then
With Sheets.Add
.Move after:=Sheets(Sheets.Count)
.name = subfolder
.Cells(1).Resize(UBound(sn) + 1) = WorksheetFunction.Transpose(sn)
.Columns(1).TextToColumns , xlDelimited, semicolon:=True
End With
End If
Next
If Sheets.Count = 3 And Sheets(Sheets.Count).name = "Sheet3" Then
MsgBox "no subfolder contained the string '" & serie & "' or your choosen filepath contained spaces"
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
End If
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
Application.DisplayAlerts = True
End Sub