I have 250 different excel files inside a folder (with same layout) with columns A to F. I need to add a new column on column G. The conventional approach would be opening each file and adding new column at G. Is there any simple process using Excel macro or any other tools to get this done?
This link helped me. Following is my solution, which works:
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\Users\dell\Desktop\Folder1\" 'Your Directory
MyFile = Dir(MyDir & "*.xlsx") 'Your excel file extension
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
Do While MyFile <> ""
Workbooks.Open (MyFile)
Range("G1").Value = "NewColumn" 'New Column Name
ActiveWorkbook.Save
ActiveWorkbook.Close True
MyFile = Dir()
Loop
End Sub
Yes here's the code for open all excel files in a folder: macro - open all files in a folder
In that loop you can add a new Column to that files
Related
I have a directory with 6 sub-folders and ~300 excel workbooks(Growing every day).
Each workbook has multiple formulas (~1200 per workbook) that reference a CSV data dump stored on a server path.
My issue is that excel treats the CSV data dump as "dirty data" and prompts warnings every time a workbook is opened claiming it can't update the links(But when the links are checked, excel then says there's no issue).
In all my research I've found there doesn't seem to be a way to fix this other than replace the datasource with a .xsl file which excel doesn't have any issues referencing.
What I need to do, is perform a find and replace on ~300 workbooks, find the CSV server path inside the formulas and replace it with the new server path for the .xls file.
I've tried "Sobolsoft's Excel Find and Replace" software, but that doesn't seem to want to look inside formulas to replace. I've used "Easy-XL" and "Kutools" both of which only work on open workbooks (Which I could live with, if I had to open 20-50 workbooks at a time, run the find and replace, then open the next batch) but neither of them wanted to work either.
I've used the following macro to unprotect/protect each workbook in the directory which works perfectly
Const cStartFolder = "M:\Transfer\DrillHole_Interaction\4.For_Survey" 'no slash at end
Const cFileFilter = "*.xlsm"
Const cPassword = "" 'use empty quotes if blank
Sub UnprotectAllWorksheets()
Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet
ExtractFolder cStartFolder, arr()
On Error Resume Next
j = -1: j = UBound(arr)
On Error GoTo 0
For i = 0 To j
Set wkb = Workbooks.Open(arr(i), False)
For Each wks In wkb.Worksheets
wks.Protect cPassword, True, True
Next
wkb.Save
wkb.Close
Next
End Sub
Sub ExtractFolder(Folder As String, arr() As String)
Dim i As Long, objFS As Object, objFolder As Object, obj As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(Folder)
For Each obj In objFolder.SubFolders
ExtractFolder obj.Path, arr()
Next
For Each obj In objFolder.Files
If obj.Name Like cFileFilter Then
On Error Resume Next
i = 0: i = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(i)
arr(i) = objFolder.Path & Application.PathSeparator & obj.Name
End If
Next
End Sub
If it would help, I'm also open to copying from a 'Master' workbook and copying the specific range into each other workbook (Copy range to range for each book) but I'm at my wits end and do not know how to proceed.
Any help would be appreciated.
No need to find and replace the csv fullname (path & filename) within all formulas, just change the links source at once within each workbook.
Try this within a loop through all workbooks that need to be changed.
Dim Wbk As Workbook
Application.DisplayAlerts = False
Set Wbk = Workbooks.Open(Filename:="WbkTarget.Fullname", UpdateLinks:=3)
With Wbk
.ChangeLink _
Name:="CsvFile.Fullname", _
NewName:="XlsFile.Fullname", _
Type:=xlExcelLinks
.Save
.Close
End With
Application.DisplayAlerts = True
where:
WbkTarget.Fullname: Path and name of the workbook with the link to be replaced
CsvFile.Fullname: Path and name of the csv file to be replaced
XlsFile.Fullname: Path and name of the xls that replaces the csv file
I have a requirement from the client in which they want us to rename the column from multiple excel sheets which are present in the same directory.
There are 70+ excel reports and we are not sure that the particular column is present in which excel file. So every time they ask us to change, all the time we have to drill down all the excel sheets to find out the changes required which is really time consuming.
I thought of automating the process. Since all the files are present under the same directory, can't we use a MACRO,BATCH/UNIX SCRIPTS or any other way by which we can traverse the entire directory and make those changes by performing a find and replace thing.
So my first question is, if this is feasible ? If yes, then can anyone suggest/advice how to work around on this process ?
Thanks in Advance
I can't take full credit for the below as this is a patchwork of code I have used over the years. This is how I would go about it personally:
Manually make a copy of the files to change and place them in a folder (keep the originals safe!)
Let the code open each file and change it
Code will save a copy in a different 'done' folder
The example below loops through each Excel file and moves it from the 'to-do' folder to the 'done' folder once it has changed the cell "A1" to "Hello World". When the 'to-do' folder is empty the code stops.
You'll need to change the file paths for this to work.
Sub Example()
Dim FolderPath As String, FilePath As String, FileCount As Integer
Dim objExcelApp As Object
Dim wb As Object
Dim SaveName As String
FolderPath = "C:\Users\********\Desktop\To Do\"
NewFolderPath = "C:\Users\********\Desktop\Done\"
FilePath = FolderPath & "*.xl??"
FileName = Dir(FilePath)
ChangeNextFile:
FileCount = 0
'count how many files in "files to be changed" folder
Do While FileName <> ""
FileCount = FileCount + 1
FileName = Dir()
Loop
'if there are no files left end the code
If FileCount = 0 Then GoTo FinishedLoadingFiles
'choose the first file to change
FileName = Dir(FilePath)
Debug.Print FileName
'create an instance of Excel
Set objExcelApp = CreateObject("Excel.Application")
With objExcelApp
.Visible = False
.DisplayAlerts = False
End With
'opens the excel file in the background
objExcelApp.Workbooks.Open FileName:=FolderPath & FileName, UpdateLinks:=False
Set wb = objExcelApp.ActiveWorkbook
objExcelApp.ActiveWindow.Activate
'changes cell "A1" to say "hellow world"
wb.Sheets(1).Cells(1, 1).Value = "Hello World"
'saves the file in the done pile
wb.saveas NewFolderPath & FileName '& ".xlsb"
'closes excel
With objExcelApp
.DisplayAlerts = True
End With
wb.Close
objExcelApp.Quit
Set wb = Nothing
Set objExcelApp = Nothing
'deletes the original file. New file has been saved in the new folder
Kill FolderPath & FileName
GoTo ChangeNextFile
FinishedLoadingFiles:
MsgBox "All done"
End Sub
I'm trying to make a merge file script just as this question.
https://stackoverflow.com/a/4148797/1864883
It's working fine, it's copping the files into new worksheets inside the same new workbook.
The only problem is that the colours are not been the same in the target file.
Here is a screenshot comparing input and output:
Here is the macro that I'm running to accomplish the task:
Option Explicit
'Ref: https://stackoverflow.com/a/26474331/1864883
Private Sub MergeFiles()
Dim directory As String, fileName As String, sheet As Worksheet, total As Integer
Dim WrdArray() As String, currentFile As Workbook, thisFile As Workbook, output As Workbook, outputName As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set thisFile = ActiveWorkbook 'Reference for current workbook
directory = thisFile.Sheets("teste1").Cells(2, 2).Value 'Get path of files to merge from cell B2
outputName = thisFile.Sheets("teste1").Cells(3, 2).Value 'Get output file name from cell B3
fileName = Dir(directory & "*.xl??")
Set output = Workbooks.Add 'Create new workbook for output
'Ref: https://stackoverflow.com/a/4148797/1864883
Do While fileName <> ""
Set currentFile = Workbooks.Open(directory & fileName) 'Open file as current file
WrdArray() = Split(fileName, ".") 'Split file name in `.` to get name without extension
For Each sheet In currentFile.Worksheets 'Interate each sheet
currentFile.ActiveSheet.Name = WrdArray(0) 'Changes sheet name to same as file name
sheetsInOutput = output.Worksheets.Count 'Amount of seets in output
currentFile.Worksheets(sheet.Name).Copy after:=output.Worksheets(sheetsInOutput)
GoTo exitFor:
Next sheet
exitFor:
currentFile.Close
fileName = Dir()
Loop
output.Worksheets(1).Delete 'Delete first sheet crated when output created
output.SaveAs fileName:=thisFile.Path & "\" & outputName 'Saves output in same directory as this file
output.Close 'closes output file
'thisFile.Close
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'Referência: https://stackoverflow.com/a/2051420/1864883
Private Sub Workbook_Open()
Call MergeFiles ' Call your macro
'ActiveWorkbook.Save ' Save the current workbook, bypassing the prompt
'Application.Quit ' Quit Excel
End Sub
PS: I tested with some other files that worked just fine, These file that I'm getting trouble are from Crystal Report.
Read this: https://msdn.microsoft.com/en-us/library/office/ff821660.aspx
You need make sure that both workbooks have same color.
Example:
ThisWorkbook.Colors = Workbooks(2).Colors
I have a folder in my Desktop with more or less 2000 csv files. Those files have only 1 "Sheet" but the sheet name varies. The only similar thing is that it starts with the word "Tankard".
In that one sheet, I just need to remove Column A and Save it, for all 2000 files. Its only my 2nd month to explore vba automation at work. I'd appreciate if someone can help me. Thanks in advance.
Script:
Sub Tank()
Dim wb As Workbook
Dim myPath As String
Dim myfile As String
Dim myExtension As String
Dim SheetName As String
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
SheetName = "Tankard*"
myPath = "\\ph00winfdfs01p\shares\JoeyC\documents\Roaming\Windows\Desktop\Tank\"
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "Tankard*.csv"
'Target Path with Ending Extention
myfile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
For i = 1 To 201
Set wb = Workbooks.Open(Filename:=myPath & myfile)
';;;;;;;;;;;;;;WRITE YOUR CODE HERE
Sheets("SheetName").Select
Columns("A").Select
Selection.Delete
wb.Close SaveChanges:=True
Next i
'Get next file name
myfile = Dir
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Try to understand what's happening. What this sub does at the moment is opening the first workbook that Dir can find, opening it 201 times and deleting the first column of sheet "Sheetname" every time.
Sheets("SheetName").Select
This selects the sheet with the name "Sheetname", not the name with the value that you set the string Sheetname to. If anything, it should be Sheets(Sheetname) but wildcards don't work here anyways.
Now let's look at the process you're trying to achieve.
myfile = Dir(myPath & myExtension)
sets myfile to the first file that matches your pattern ...\Tankard*.csv
Set wb = Workbooks.Open(Filename:=myPath & myfile)
opens the file and now you can access the workbook via wb
To delete the first column on the sheet I would recommend selecting all that stuff but deleting the range directly:
wb.Sheets(1).Columns(1).Delete 'If you want to actually delete the column
wb.Sheets(1).Columns(1).Clear 'If you want to just remove the values
As you can see you don't need the name of the sheet at all. Now save the workbook:
wb.Close SaveChanges:=True
Now you can set myfile to the next filename using Dir:
myfile = Dir
Then repeat that until there are no more files (at that point Dir will return "". The best way to achieve that is to use a While loop, e.g. like this
While myfile <> ""
'Do stuff here
Wend '(While End)
The advantage over a For loop is that you don't need to know the exact number of files in your folder.
I'll leave it up to you to patch that all together.
I want to collect data from different files and insert it into a workbook doing something like this.
Do While THAT_DIFFERENT_FILE_SOMEWHERE_ON_MY_HDD.Cells(Rand, 1).Value <> "" And Rand < 65536
then 'I will search if the last row in my main worksheet is in this file...
End Loop
If the last row from my main worksheet is in the file, I'll quit the While Loop. If not, I'll copy everything. I'm having trouble finding the right algorithm for this.
My problem is that I don't know how to access different workbooks.
The best (and easiest) way to copy data from a workbook to another is to use the object model of Excel.
Option Explicit
Sub test()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim vFile As Variant
'Set source workbook
Set wb = ActiveWorkbook
'Open the target workbook
vFile = Application.GetOpenFilename("Excel-files,*.xls", _
1, "Select One File To Open", , False)
'if the user didn't select a file, exit sub
If TypeName(vFile) = "Boolean" Then Exit Sub
Workbooks.Open vFile
'Set targetworkbook
Set wb2 = ActiveWorkbook
'For instance, copy data from a range in the first workbook to another range in the other workbook
wb2.Worksheets("Sheet2").Range("C3:D4").Value = wb.Worksheets("Sheet1").Range("A1:B2").Value
End Sub
You might like the function GetInfoFromClosedFile()
Edit: Since the above link does not seem to work anymore, I am adding alternate link 1 and alternate link 2 + code:
Private Function GetInfoFromClosedFile(ByVal wbPath As String, _
wbName As String, wsName As String, cellRef As String) As Variant
Dim arg As String
GetInfoFromClosedFile = ""
If Right(wbPath, 1) <> "" Then wbPath = wbPath & ""
If Dir(wbPath & "" & wbName) = "" Then Exit Function
arg = "'" & wbPath & "[" & wbName & "]" & _
wsName & "'!" & Range(cellRef).Address(True, True, xlR1C1)
On Error Resume Next
GetInfoFromClosedFile = ExecuteExcel4Macro(arg)
End Function
Are you looking for the syntax to open them:
Dim wkbk As Workbook
Set wkbk = Workbooks.Open("C:\MyDirectory\mysheet.xlsx")
Then, you can use wkbk.Sheets(1).Range("3:3") (or whatever you need)
There's very little reason not to open multiple workbooks in Excel. Key lines of code are:
Application.EnableEvents = False
Application.ScreenUpdating = False
...then you won't see anything whilst the code runs, and no code will run that is associated with the opening of the second workbook. Then there are...
Application.DisplayAlerts = False
Application.Calculation = xlManual
...so as to stop you getting pop-up messages associated with the content of the second file, and to avoid any slow re-calculations. Ensure you set back to True/xlAutomatic at end of your programming
If opening the second workbook is not going to cause performance issues, you may as well do it. In fact, having the second workbook open will make it very beneficial when attempting to debug your code if some of the secondary files do not conform to the expected format
Here is some expert guidance on using multiple Excel files that gives an overview of the different methods available for referencing data
An extension question would be how to cycle through multiple files contained in the same folder. You can use the Windows folder picker using:
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .Selected.Items.Count = 1 the InputFolder = .SelectedItems(1)
End With
FName = VBA.Dir(InputFolder)
Do While FName <> ""
'''Do function here
FName = VBA.Dir()
Loop
Hopefully some of the above will be of use
I had the same question but applying the provided solutions changed the file to write in. Once I selected the new excel file, I was also writing in that file and not in my original file. My solution for this issue is below:
Sub GetData()
Dim excelapp As Application
Dim source As Workbook
Dim srcSH1 As Worksheet
Dim sh As Worksheet
Dim path As String
Dim nmr As Long
Dim i As Long
nmr = 20
Set excelapp = New Application
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
.Show
path = .SelectedItems.Item(1)
End With
Set source = excelapp.Workbooks.Open(path)
Set srcSH1 = source.Worksheets("Sheet1")
Set sh = Sheets("Sheet1")
For i = 1 To nmr
sh.Cells(i, "A").Value = srcSH1.Cells(i, "A").Value
Next i
End Sub
With excelapp a new application will be called. The with block sets the path for the external file. Finally, I set the external Workbook with source and srcSH1 as a Worksheet within the external sheet.