I want to loop through all Workbooks in a folder and then loop through all worksheets of each workbook. I have the code below but currently the problem is with the line For Each ws in StrFile.Sheets:
Sub LoopThroughFiles()
Dim StrFile As String
StrFile = Dir("C:\Users\A9900899\Desktop\bob\VBAProject\Raw\")
Do While Len(StrFile) > 0
Debug.Print StrFile
For Each ws In StrFile.Sheets
Debug.Print ws.Name
Next ws
StrFile = Dir
Loop
End Sub
What is my mistake here?
In order to loop through all Workbook.Sheets you need to Set wb to the current StrFile, and then loop through wb.Sheets.
Using Application.ScreenUpdating = False and Application.DisplayAlerts = False will minimize all screen flickering and Excel alerts.
Code
Option Explicit
Sub LoopThroughFiles()
Dim StrFile As Variant
Dim fPath As String
Dim wb As Workbook
Dim ws As Worksheet
fPath = "C:\Users\A9900899\Desktop\bob\VBAProject\Raw\"
StrFile = Dir(fPath)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
While StrFile <> ""
Debug.Print StrFile
If StrFile Like "*xls*" Then ' check that current file is Excel type
Set wb = Workbooks.Open(fPath & StrFile)
For Each ws In wb.Sheets
Debug.Print ws.Name
Next ws
wb.Close False ' close workbook and don't save changes
End If
StrFile = Dir
Wend
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
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'm trying to use msoFileDialogFolderPicker to select a folder and then loop through the folder. I can't seem to get Do While Len(myFile) > 0 to trigger with FolderPicker if I specifyfilepath with C:\Test\ it works perfectly.
Option Explicit
Sub LoopThroughDirectory()
Dim myFile As String, filepath As String
Dim wbc As Long, ws As Worksheet, wb As Workbook
Dim diaFolder As FileDialog
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
If diaFolder.Show = -1 Then
myFile = diaFolder.SelectedItems(1)
End If
wbc = 0
filepath = diaFolder
Application.ScreenUpdating = False
'Only try to open xlsm workbooks
myFile = Dir(filepath & "*.xlsm*")
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)
'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("A2:B2")
ThisWorkbook.Worksheets("AMT").Range("B4").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
End Sub
The reason it does not work is because you assign myFile to the wrong variable:
Your code:
filepath = diaFolder
Correct code:
filepath = myFile
PLUS
myFile = Dir(filepath & "*.xlsm*")
should be
myFile = Dir(filepath & "\*.xlsm")
Hi I have the following code to copy all worksheets of all workbooks in a given folder to a single workbook. I need to modify this code to copy only the active sheet on all workbooks (now it copies all the sheets). Can you help me with this?
Option Explicit
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:\" '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
This way you can do what you want:
Option Explicit
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:\" 'Change as needed
FileName = Dir(Path & "\*.xlsx", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName)
ActiveSheet.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
'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
Note:
When you open the workbook, you go over all the sheets with the FOR LOOP, but you only need to copy the ActiveSheet then (as you said) you only need to copy to the new Wrokbook
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
This is part of the sub I found to copy all tabs in all workbooks in a directory to my current workbook, but how can I adjust it to scan all subfolders as well? Currently, it only copies from the folder I select and then stops.
Here's the full code with functions: http://www.vbaexpress.com/kb/getarticle.php?kb_id=829
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls*", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & FileName)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
Using the code I posted in the linked question (untested)
Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String
Dim colFiles As New Collection, fPath
ThisWB = ThisWorkbook.path & "\" & ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
GetFiles path, "*.xls*", True, colFiles
For Each fPath In colFiles
If fPath <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=fPath)
For Each WS In Wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
Wkb.Close False
End If
Next fPath
Application.EnableEvents = True
Application.ScreenUpdating = True
Set Wkb = Nothing
Set LastCell = Nothing
End Sub
VBA macro that search for file in multiple subfolders