I'm trying to open multiple Excel files and add the same new cell with same name to each. They are in a folder .../desktop/excel named workbook1, workbook2, etc.
I tried this article already but I'm getting a runtime error 76 'Path not found'.
I'm super novice with VBA, any help is appreciated! This is the script I'm running:
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\shaye\Desktop\excel" '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
[
try this code. I think you need this "\" in your directory and "??" in your file extension to find several excel types
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\shaye\Desktop\excel\" 'Your Directory need this "\"
MyFile = Dir(MyDir & "*.xl??") 'Your excel file extension
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
Related
I have a macro excel file that does some clean up on cells and I need to import a single sheet from various files on the same folder. For example I need the sheet1 from all the excel files located on the same folder as my macro file. I have a code to do that manually but I need to be able to do it automatically either by selecting the files or running another macro to select them no matter the amount of files on the folder.
Sub Carga_Masiva()
Dim fName As String, wb As Workbook
fName = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
I'd prompt user for a folder and then iterate over each file except the one with your macro.
To prompt for a folder use this solution (in my code as optional variant): link
Complete code below:
Sub Carga_Masiva()
Dim sh As Worksheet
Dim fName As String, wb As Workbook
fName = Application.GetOpenfnamename("Excel fnames (*.xl*), *.xl*")
Set wb = Workbooks.Open(fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
sh.Copy Before:=ThisWorkbook.Sheets(1)
Exit For
End If
Next
wb.Close False
End Sub
Sub CopyToThisWorkbook()
Dim wbMacro, wb As Workbook
Set wbMacro = ThisWorkbook
Dim sh As Worksheet
Dim folderPath, fName, tabName As String
folderPath = wbMacro.Path & Application.PathSeparator
'Prompt variant
'folderPath = GetFolder & Application.PathSeparator
fName = Dir(PathName:=folderPath)
Do
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Open all files except the one with macro
If fName <> wbMacro.Name Then
'Your code
Set wb = Workbooks.Open(wbMacro.Path & "\" & fName)
For Each sh In wb.Sheets
If Application.CountA(sh.Cells) > 0 Then
tabName = sh.Name & "_" & Right(wb.Name, 10) 'Optional - rename Worksheet to be copied
sh.Name = tabName 'Optional
sh.Copy Before:=wbMacro.Sheets(1)
Exit For
End If
Next sh
wb.Close SaveChanges:=False
End If
fName = Dir
Loop Until fName = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Function GetFolder() As String 'Optional variant
Dim fldr As fnameDialog
Dim sItem As String
Set fldr = Application.fnameDialog(msofnameDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialfnameName = Application.DefaultfnamePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
I have 99 workbooks in a folder. I want to copy sheet1 from each into a new workbook. It doesn't matter what order as long as each workbook/sheet1 goes onto a new worksheet in the destination workbook.
I have written a code, and tried to sample other codes. No matter what it will only copy sheet1 of the first 10 workbooks.
How can this work on all the workbooks in the folder? My goal is to get the sheets together so I can merge certain cells into a summary sheet.
I put this code into a module on my destination workbook.
Sub combineWorkbooks()
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*.xls") Do While fileName <> ""
Workbooks.Open fileName:=Path & fileName, ReadOnly:=True
For Each sheet In ActiveWorkbook.Sheets
sheet.Copy After:=ThisWorkbook.Sheets(1)
Next sheet
Workbooks(fileName).Close
fileName = Dir() Loop
End Sub
EDIT: this should prevent any issues trying to copy multiple sheets with the same name into the workbook.
Sub combineWorkbooks()
Dim Path, fileName, sheetNum As Long, sheetName As String
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*.xls")
Do While fileName <> ""
With Workbooks.Open(fileName:=Path & fileName, ReadOnly:=True)
sheetName = .Worksheets(1).Name
sheetNum = 1
'if a worksheet with the same name already exists, add
' an incrementing number until the name is unique
If WorksheetExists(sheetName) Then
Do While WorksheetExists(sheetName & sheetNum)
sheetNum = sheetNum + 1
Loop
.Worksheets(1).Name = sheetName & sheetNum 'rename if required
End If
'copy to end of sheets
.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Close
End With
fileName = Dir()
Loop
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
If you're still getting only 10 files then maybe it's an issue with the file names/extensions?
Edit - try listing all of the files:
Dim Path, fileName
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0001-JJ0099\"
fileName = Dir(Path & "*")
Do While fileName <> ""
Debug.Print fileName
fileName = Dir()
Loop
What output do you get?
It was a file name extension, as you thought.
I now have this working.
Sub CombineFiles()
Dim Path As String
Dim FileName As String
Dim Wkb As Workbook
Dim WS As Worksheet
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\Users\james\OneDrive\Desktop\Invoices Jones UK Group\Paid\JJ0800-JJ0899" 'Change as needed
FileName = Dir(Path & "\*.xlsx", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
For Each WS In Wkb.Worksheets
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Next WS
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I have a macro that works in any Excel workbook but doesn't work once I place it in my PERSONAL.XLSB file. My goal is to take the tabs from all of the files in a folder on my desktop and copy them into the active file. I know the issue is that I am using This.Workbook as the location reference for the copied tabs but I don't know how else to reference the workbook I am trying to copy the tabs into. I don't want to reference a filepath for where to copy the tabs since this will be used by multiple people in multiple files. Any thoughts would be greatly appreciated.
Sub CombineWorkbooks()
Dim Path As Variant
Path = GetFolder(1) & "\"
Dim FileName As String
FileName = Dir(Path & "*.xl??")
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open Path & FileName
For Each ws In ActiveWorkbook.Sheets
ws.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Next ws
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
If you define the file to a variable or activeworkbook it should work.
UPDATED as I think I slightly misunderstood the overall objective of macro but the concept is still the same. Let me know if this doesn't work.
Sub CombineWorkbooks()
Dim Path As Variant
Path = GetFolder(1) & "\"
Dim FileName As String
FileName = Dir(Path & "*.xl??")
Dim ws As Worksheet, wkBkToCopyTo As Workbook
Set wkBkToCopyTo = ActiveWorkbook 'assuming that you run this with the destination open.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While FileName <> ""
Workbooks.Open Path & FileName
For Each ws In ActiveWorkbook.Sheets
ws.Copy after:=wkBkToCopyTo.Worksheets(wkBkToCopyTo.Worksheets.Count)
Next ws
Workbooks(FileName).Close
FileName = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End Sub
You could also try to find it based on its name:
'you could also use a loop to find it
For Each wkBkToCopyTo In Application.Workbooks
If InStr(1, wkBkToCopyTo.Name, "someNameof the workbook", vbTextCompare) > 0 Then
Exit For
End If
Next wkBkToCopyTo
I am using an Array of File extensions and looping through a folder of workbooks. The code is naming Sheet(1).name="MyName"
I notice that even though "*.xlsm" is not in the array, it is still opening and naming the sheet.
Here's the code. Can anybody see if they get the same problem and are able to solve it.
Sub LoopThroughFolder()
Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook
Dim Rws As Long, Rng As Range
Dim fExt, ext
Set Wb = ThisWorkbook
'change the address to suite
MyDir = "C:\TestWorkBookLoop\"
ChDir MyDir
Application.ScreenUpdating = 0
Application.DisplayAlerts = 0
fExt = Array("*.xlsx", "*.xls") 'file extensions, set the file extensions of the files to move
For Each ext In fExt 'loop through file extensions
MyFile = Dir(MyDir & ext)
Do While MyFile <> ""
Workbooks.Open (MyFile)
Sheets(1).Name = "MySheet"
With ActiveWorkbook
.Save
.Close
End With
MyFile = Dir()
Loop
Next ext
End Sub
The legacy short (8.3) file name for HELLO.ABCD would look something like ABCDEF~1.ABC - see the extension is truncated to 3 characters.
In your case GET.XLSM would be ABCDEF~1.XLS and this 8.3 form is also matched by the Win32 API FindFirstFile (which is what Dir() calls under the hood) when you specify *.XLS
Just filter out the exceptions in you loop with
If Not UCase$(MyFile) Like "*.XLSM" Then
....
While Alex has solved your query, I have updated your code below to
ensure it handles all excel file types
handle the sheet name already existing (else your code will error out)
cleanup and properly use variables
restore events at close
Sub LoopThroughFolder()
Dim Wb As Workbook
Dim MyFile As String
Dim MyDir As String
Dim StrFile As String
MyDir = "C:\temp\"
ChDir MyDir
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
StrFile = "*.xls*"
MyFile = Dir(MyDir & StrFile)
Do While Len(MyFile) > 0
If MyFile Like "*.xlsx" Or MyFile Like "*.xlx" Then
Set Wb = Workbooks.Open(MyFile)
On Error Resume Next
Wb.Sheets(1).Name = "MySheet"
On Error GoTo 0
Wb.Save
Wb.Close False
End If
MyFile = Dir()
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Alright I am trying to extract data from several workbooks in a folder and put them all in one file. When the code hits Workbooks.Open, error 1004 pops up and I am sure that the files are not corrupted.
Sub Extract_Class_Data()
' Extract_ERP_Class_Data Macro
' Goes into all the files in the folder and extracts the data from each of them.
Dim MyFile As String
Dim sourceBook As Workbook
Dim sourceSheet As Worksheet
Dim sourceSheetSum As Worksheet
Set sourceBook = ActiveWorkbook
Set sourceSheet = sourceBook.Sheets("Sheet1")
Dim erow
Dim Filepath As String
Filepath = ThisWorkbook.Path
MyFile = Dir(Filepath & "\*.xlsx")
Do While Len(MyFile) > 0
If MyFile = "ZZZ.xlsm" Then
Exit Sub
End If
**Workbooks.Open (MyFile)**
Worksheets(Data).Activate
Range("B6:B12").Select
Selection.Copy
ActiveWorkbook.Close savechanges:=False
sourceSheet.Select
ActiveSheet.Paste
Range("B1").Select
ActiveCell.Offset(0, 1).Select
MyFile = Dir
Loop
End Sub
This works:
Public Sub openaworkbook()
Dim filen As String, filepath As String, myfile As String
filen = "temp.xlsx"
filepath = "c:\temp\"
myfile = Dir(filepath & filen)
Workbooks.Open (filepath & myfile)
End Sub
You need filepath in the open command, as DIR does not return the path, only the filename.