Looping through opened Workbooks
Its a code to which runs through all opened workbooks but here's a problem that it runs about 10 to 12 times then stops. Can anybody gimme any idea...
Sub OpenAllWorkbooks()
Set destWB = ActiveWorkbook
Dim DestCell As Range
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.csv*),*.csv*", _
Title:="Select the workbooks to load.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set wb = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
Next n
Dim cwb As Workbook
For Each cwb In Workbooks
'With Application
'cwb.AcceptAllChanges
'End With
Call donemovementReport
ActiveWorkbook.Close True
ActiveWorkbook.Close False
Next cwb
End Sub
Why open all workbooks in one go? Open them one by one and then close them as your work is done. For example (Untested)
Sub OpenAllWorkbooks()
Dim wb As Workbook, thisWb As Workbook
Dim DestCell As Range
Dim FileNames As Variant
Dim n As Long
Set thisWb = ThisWorkbook
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.csv*),*.csv*", _
Title:="Select the workbooks to load.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For n = LBound(FileNames) To UBound(FileNames)
Set wb = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
Call donemovementReport
wb.Close SaveChanges:=True
Next n
End Sub
The solution I use to cycle many files in 95% of cases - perhaps may be helpful:
Sub CSV_Cycling()
InputFolder = "D:\DOCUMENTS\"
LoopFileNameExt = Dir(InputFolder & "*.csv")
Do While LoopFileNameExt <> ""
'Application.DisplayAlerts = False
Application.Workbooks.Open (InputFolder & LoopFileNameExt)
'Application.DisplayAlerts = True
[..........YOUR CODE..........]
LoopFileNameExt = Dir
Loop 'Input Folder Files Cycling
End Sub
Uncomment Application.DisplayAlerts = strings to avoid any warnings - if required (however be careful - files will be opened using "default" options) and change source path, of course).
Related
I'm trying to:
Copy cell "B2:C2" from every workbook in a folder from the "Results" worksheet.
Paste the value into Cell A1:A2 Sheet1 in workbook "x"in the same folder.
I think I know how to open and do something to every workbook within a folder.
Option Explicit
Sub LoopThroughDirectory()
Dim MyFile As String
Dim WorkbookCounter As Long
WorkbookCounter = 1
Dim Filepath As String
Dim wb As Workbook
Dim RowCounter As Long
RowCounter = 1
Filepath = "C:\Test\"
Application.ScreenUpdating = False
MyFile = Dir(Filepath)
'Opens workbooks located C:\Test\ in order
Do While Len(MyFile) > 0
Set wb = Workbooks.Open(Filepath & MyFile)
Application.DisplayAlerts = False
'Copy cells B2 & C2 from the results worksheet
ThisWorkbook.Worksheets("x").Range(Cells(RowCounter, 1), Cells(RowCounter, 2)).Value = _
wb.Worksheets("Results").Range("B2:C2").Value
'Close wb most recently opened
wb.Close SaveChanges:=False
Application.CutCopyMode = False
WorkbookCounter = WorkbookCounter + 1
If WorkbookCounter > 1000 Then
Exit Sub
End If
MyFile = Dir
RowCounter = RowCounter + 1
Loop
ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub
Update: With help in the comments below the above code now correctly loops through the correct folder and updates cell A1:A2.
Instead of overwriting cell A1:A2 I'd like to paste the copied text one line down.
i.e. Workbook 1 = A1:A2, Workbook 2 = B1:B2, etc
I don't see any check to make sure you are not trying to open ThisWorkbook and there is no check to see if there is a Results worksheet in the source workbook; in fact there is no check to ensure that you are trying to open a workbook at all, you could be trying to open a JPG.
Further error control could be added to ensure that you are not trying to open another workbook that is already open. I suspect that after all the testing, you might have a few.
Option Explicit
Sub LoopThroughDirectory()
Dim myFile As String, filepath As String
Dim wbc As Long, ws As Worksheet, wb As Workbook
wbc = 0
filepath = "C:\Test\"
'Application.ScreenUpdating = False
'only try to open workbooks
myFile = Dir(filepath & "*.xls*")
'Opens workbooks located C:\Test\ in order
Do While Len(myFile) > 0
'make sure myFile isn't ThisWorkbook
If Split(myFile & ".", ".")(0) <> Split(ThisWorkbook.Name & ".", ".")(0) Then
Set wb = Workbooks.Open(Filename:=filepath & myFile, ReadOnly:=True)
'Application.DisplayAlerts = False
'check if there is a Results worksheet
On Error Resume Next
Set ws = wb.Worksheets("Results")
On Error GoTo 0
If Not ws Is Nothing Then
'transfer cells B2 & C2 from the results worksheet
With ws.Range("B2:C2")
ThisWorkbook.Worksheets("x").Range("A1").Offset(wbc, 0).Resize(.Rows.Count, .Columns.Count) = .Value
End With
End If
'Close wb most recently opened
wb.Close SaveChanges:=False
wbc = wbc + 1
If wbc > 1000 Then Exit Do
End If
Set ws = Nothing
myFile = Dir
Loop
ActiveWorkbook.Save
'Application.ScreenUpdating = True
End Sub
I have a code below which copies a specific worksheets form all active or open workbooks.
But how to copy the same Worksheet without opening the workbooks, like if we can provide the path in the code , it should be able to pick the given worksheet from all the workbooks form that path.
Below is the code that am currently using.
Sub CopySheets1()
Dim wkb As Workbook
Dim sWksName As String
sWksName = "SHEET NAME"
For Each wkb In Workbooks
If wkb.Name <> ThisWorkbook.Name Then
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
End If
Next
Set wkb = Nothing
End Sub
Work with Workbooks.Open Method to open it in in the background, and hide any alerts with Application / ScreenUpdating / EnableEvents / DisplayAlerts
Application.ScreenUpdating Property (Excel) Turn screen updating off to speed up your macro code. You won't be able to see what the macro is doing, but it will run faster.
Example
Sub CopySheets1()
Dim wkb As Workbook
Dim sWksName As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
wkb Workbooks.Open("C:\temp\bookname.xls")
sWksName = "SHEET NAME"
For Each wkb In Workbooks
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set wkb = Nothing
End Sub
Assuming your folder name is C:\Temp\ then Loop until folder returns an empty
Example
Dim FileName As String
' Modify this folder path as needed
FolderPath = "C:\Temp\"
' Call Dir the first time to all Excel files in path.
FileName = Dir(FolderPath & "*.xl*")
' Loop until Dir returns an empty .
Do While FileName <> ""
' Open a workbook in the folder
Set wkb = Workbooks.Open(FolderPath & FileName)
'--->> Do your copy here
' Close the source workbook without saving changes.
wkb.Close savechanges:=False
' next file name.
FileName = Dir()
Loop
Use a Do...Loop structure when you want to repeat a set of statements an indefinite number of times, until a condition is satisfied. If you want to repeat the statements a set number of times, the For...Next Statement is usually a better choice.
I am assuming that you don't want to display the opened workbook to the user so the operation is not visible on screen.
If that's the case, you can use the following line before your code
Application.ScreenUpdating = False
'open the new/target excel workbook and put all the sheets in there
And following after:
Application.ScreenUpdating = True
It seems then that you have to manually open the workbooks. You can automate this process in VBA as follows;
Sub CopySheets1()
Dim wkb As Workbook
Dim dirPath As String ' Path to the directory with workbooks
dim wkbName as String
dirPath="C:\folder\"
sWksName = "SHEET NAME"
wkbName=Dir(dirPath & "*.xlsx")
For example:
dirPath = "C:\folder\"
So that the input to the Dir function be like "C:\folder*.xlsx"
Application.DisplayAlerts = False
do while wkbName <> ""
Set wkb=Application.Workbooks.Open(dirPath & wkbName)
wkb.Worksheets(sWksName).Copy _
Before:=ThisWorkbook.Sheets(1)
wk.Close False
wkbName = Dir
loop
Application.DisplayAlerts = True
End Sub
I am trying to merge many excel files (workbooks) from a folder.
My problem is that I want to move different sheets to the new excel file.
At the moment my code can only move one sheet at the time from these different files.
Example:
I have 3 excel files named
1.xlsx
2.xlsx
3.xlsx
all 3 files have 3 sheets in it and I want to take sheet1 from 1.xlsx and sheet1 and sheet2 from 2.xlsx and finally sheet3 from 3.xlsx and put in a new excel file.
My code at the moment can only takes one sheet (and same sheet number) from each file and put in the new file.
My code so fare:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=path & "\" & Filename)
sheet = 1
Set wsSrc = wbSrc.Worksheets(sheet)
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Many thank in advance
You need to loop through all the Sheets in the current Workbook found in your folder.
Try the code below:
Sub MergeMultiSheets()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim Path As String
Dim Filename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Path = "C:\Users\*ChangeThis*\Desktop\merge"
Set wbDst = Workbooks.Add(xlWBATWorksheet)
Filename = Dir(Path & "\*.xlsx", vbNormal)
If Len(Filename) = 0 Then Exit Sub
Do Until Filename = ""
Set wbSrc = Workbooks.Open(Filename:=Path & "\" & Filename)
Sheet = 1
' ****** you need to loop on all sheets per Excel workbook found in Folder ******
For Each wsSrc In wbSrc.Sheets
wsSrc.Copy After:=wbDst.Worksheets(wbDst.Worksheets.Count)
Next wsSrc
wbSrc.Close False
Filename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
I am using a macro that opens each excel file in the same folder that the workbook containing the macro (I'll call it the master workbook) is in and copies all the data in the first spreadsheet, then pastes them into the master workbook on a new worksheet. I found some very useful code online that I made a few changes to. Everything seems to be working fine, except that while this code is opening each file in the folder (in the Do Until loop), it opens itself half way through.
I'd like to be able to avoid this without referencing the master spread sheet's name directly, in case someone renames it.
Is there a simple command that will make skip the remaining code in the loop if it tries to open itself?
Code is below:
Sub CombineWSs()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim MyPath As String
Dim strFilename As String
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
MyPath = ThisWorkbook.Path
Set wbDst = ThisWorkbook
strFilename = Dir(MyPath & "\*.xls", vbNormal)
If Len(strFilename) = 0 Then Exit Sub
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Set wsSrc = wbSrc.Worksheets(1)
'copy the data
wbSrc.ActiveSheet.UsedRange.Select
Selection.Copy
'create a new worksheet in this master file
wbDst.Sheets.Add After:=Sheets(Sheets.Count)
'paste the data into master file's new sheet
wbDst.Sheets(wbDst.Worksheets.Count).Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
wbSrc.Close False
strFilename = Dir()
Loop
wbDst.Worksheets(1).Delete
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Put an If block inside our loop
Do Until strFilename = ""
If strFilename <> wbDest.Name Then 'since you already set wbDest = ThisWorkbook
'... rest of code
End If
Loop
I want to cycle through all workbooks in a folder, extract worksheets named "Sheet Name", and save them as .csv files with the name of the file from which they originated. What's quick way to do this?
Example of vba function in question:
Sub Sheet_SaveAs()
Dim wb As Workbook
Sheets("Sheet Name").Copy
Set wb = ActiveWorkbook
With wb
.SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.name, FileFormat:=xlCSV
'.Close False
End With
End Sub
Many thanks for looking
EDIT: Not a duplicate because I am working on extracting sheets from multiple workbooks, and not multiple worksheets from a single workbook.
EDIT2: thank you, everyone.
Something like this.
Change this path to suit your folder
strFolder = "c:\temp"
code
Sub LoopThroughFiles()
Dim Wb As Workbook
Dim ws As Worksheet
Dim strFolder As String
Dim strFile As String
strFolder = "c:\temp"
strFile = Dir(strFolder & "\*.xls*")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Do While Len(strFile) > 0
Set Wb = Workbooks.Open(strFolder & "\" & strFile)
Set ws = Nothing
On Error Resume Next
Set ws = Wb.Sheets("Sheet Name")
On Error GoTo 0
If Not ws Is Nothing Then ws.SaveAs Left$(Wb.FullName, InStrRev(Wb.FullName, ".")) & "csv", FileFormat:=xlCSV
Wb.Close False
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub