I've been working my way through a macro that will merge the first visible worksheet from an entire folder of selected workbooks. With plenty of help, I have the code working for the first worksheet in each workbook, but it is picking up hidden worksheets and I only want the first visible sheet. Here is the code so far:
Option Explicit
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
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 = GetFolder("Navigate to folder")
FileName = Dir(Path & "\*.xl??", vbNormal)
Do Until FileName = ""
Set Wkb = Workbooks.Open(FileName:=Path & "\" & FileName, ReadOnly:=True, UpdateLinks:=False)
Wkb.Worksheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Wkb.Close False
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
you can loop until a visible worksheet is found
Dim i As Long
i = 1
Do While Wkb.Worksheets(i).Visible = False
If i >= Wkb.Worksheets.Count Then
MsgBox "No visible sheet found"
Exit Do
End If
i = i + 1
Loop
Debug.Print Worksheets(i).Name 'first visible sheet
Related
I'm trying to loop through all Excel files in subfolders of a folder designated by a user and copy and paste data to a new workbook named "Compilation". This code works up to creating and saving a new workbook but data wouldn't copy and paste to the workbook.
Can anyone please help?
Sub LoopCopyPasteSubfolders()
Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FdrPicker
.Title = "Select a Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
'in case of cancel
If MyPath = "" Then GoTo ResetSettings Else
Dim NewWB As Workbook
Set NewWB = Workbooks.Add
ActiveWorkbook.SaveAs Filename:="C:\Batch\Compilation.xlsx", FileFormat:=xlWorkbookNormal
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)
Set subfolder = folder.subfolders
For Each subfolder In folder.subfolders
Set wb = subfolder.Files
For Each wb In subfolder.Files
If fso.GetExtensionName(wb.Path) = "*.xls*" Then
Workbooks.Open wb, ReadOnly:=True
Range("A1:M1").End(xlDown).Copy
For Each cell In Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells
If IsEmpty(cell) = True Then cell.PasteSpecial Paste:=xlPasteValues
'exit when value pasted to the first empty row
Exit For
Next cell
End If
Next wb
Next subfolder
'reset settings to default
ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Sub LoopCopyPasteSubfoldersIII()
Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Dim wba As Workbook
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FdrPicker
.Title = "Select a Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
'in case of cancel
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings Else
Dim NewWB As Workbook
Set NewWB = Workbooks.Add
NewWB.SaveAs Filename:="C:\Users\405458\Downloads\Compilation.xlsx",
FileFormat:=xlWorkbookNormal
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)
For Each subfolder In folder.subfolders
For Each wb In subfolder.Files
If fso.GetExtensionName(wb.Path) = "*.xls*" Then
Set wba = Workbooks.Open(wb.Path & "\" & wb.FullName, , True)
wba.Worksheets(1).Range("A1:M20").Copy
For Each cell In
Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells
If IsEmpty(cell) = True Then
cell.PasteSpecial Paste:=xlPasteValues
'exit when value pasted to the first empty row
End If
Exit For
Next cell
wba.Close False
NewWB.Save
End If
Next wb
Next subfolder
'reset settings to default
ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
This is finalized code that loops through all subfolders in a folder selected by user and copy and paste data in any Excel files in subfolders to a new workbook.
Sub LoopCopyPasteSubfoldersIII()
Dim fso As Object
Dim wb As Object
Dim folder As Object
Dim subfolder As Object
Dim MyPath As String
Dim MyFile As String
Dim FdrPicker As FileDialog
Dim wba As Workbook
Dim wbn As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Set FdrPicker =
Application.FileDialog(msoFileDialogFolderPicker)
With FdrPicker
.Title = "Select a Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
'in case of cancel
MyPath = MyPath
If MyPath = "" Then GoTo ResetSettings Else
Dim NewWB As Workbook
Set NewWB = Workbooks.Add
NewWB.SaveAs Filename:="C:\Users\405458\Downloads\Compilation.xlsx",
FileFormat:=xlWorkbookNormal
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.getfolder(MyPath)
For Each subfolder In folder.subfolders
For Each wb In subfolder.Files
If fso.GetExtensionName(wb.Path) = "xlsx" Then
wbn = fso.GetAbsolutePathName(wb)
Set wba = Workbooks.Open(Filename:=wbn)
ActiveWorkbook.Worksheets(1).Range("A1:M1").Select
Range(Selection, Selection.End(xlDown)).Copy
For Each cell In Workbooks("Compilation").Worksheets("Sheet1").Columns(1).Cells
If IsEmpty(cell) = True Then
cell.PasteSpecial Paste:=xlPasteValues
'exit when value pasted to the first empty row
Exit For
Else
End If
Next cell
wba.Close False
NewWB.Save
End If
Next wb
Next subfolder
'reset settings to default
ResetSettings:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
I want to open Excel xlsx file without writing path by using variables. I din't know why but it is not working. I have a folder with the main workbook and another one that I want to open that is xlsx. I want to name it UnionWB.
Private Sub cmdStartMonth_Click()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
'Analyze month by selecting
Dim myPath As String
Dim myFile As String
Dim UnionWB As Workbook
Dim MonthName As String
MonthName = ListMonth.Value
myExtension = "*.xlsx*"
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & myExtension)
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & myExtension)
Here's a couple of examples that may help.
The first will ask you to select the correct file and then open it:
Public Sub Test()
Dim sWrkbkPath As String
Dim UnionWB As Workbook
sWrkbkPath = GetFile(ThisWorkbook.Path)
If sWrkbkPath <> "" Then
Set UnionWB = Workbooks.Open(sWrkbkPath)
MsgBox UnionWB.Name
End If
End Sub
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select your Union Workbook"
.AllowMultiSelect = False
.Filters.Add "My Union Workbook", "*.xlsx", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
The second method assumes you only have a single xlsx file in the same folder as ThisWorkbook and opens the first file it finds:
Public Sub OpenOnlyXLSXInFolder()
Dim sWrkbkPath As String
Dim UnionWB As Workbook
sWrkbkPath = Dir$(ThisWorkbook.Path & "\*.xlsx")
'Only expecting a single file so no need to loop.
If sWrkbkPath <> "" Then
Set UnionWB = Workbooks.Open(ThisWorkbook.Path & "\" & sWrkbkPath)
MsgBox UnionWB.Name
End If
End Sub
Worksheets("Hello").Move After:=Workbooks("FILE2").Sheets(1)
I have two open active files. Hello.xlsb and FILE2.xlsb
The above code only works on my computer but not on shared drive.
I am getting "Subscript out of range error".
We need to specify the extension FILE2.xlsb to make it work.
However, I want this to work on any FILE2 with any extension.
How to make that work?
This code will ask you to open the destination workbook and move the sheet into it, is it what you're after?
Public Sub Test()
Dim vfile As Variant
Dim wrkBk As Workbook
'Ask for the location of File2.
vfile = GetFile(ThisWorkbook.Path)
Set wrkBk = Workbooks.Open(vfile)
ThisWorkbook.Worksheets("Hello").Move After:=wrkBk.Worksheets(1)
End Sub
Function GetFile(Optional startFolder As Variant = -1) As Variant
Dim fle As FileDialog
Dim vItem As Variant
Set fle = Application.FileDialog(msoFileDialogFilePicker)
With fle
.Title = "Select a File"
.AllowMultiSelect = False
.Filters.Add "Excel Files", "*.xls*", 1
If startFolder = -1 Then
.InitialFileName = Application.DefaultFilePath
Else
If Right(startFolder, 1) <> "\" Then
.InitialFileName = startFolder & "\"
Else
.InitialFileName = startFolder
End If
End If
If .Show <> -1 Then GoTo NextCode
vItem = .SelectedItems(1)
End With
NextCode:
GetFile = vItem
Set fle = Nothing
End Function
If your destination workbook is already open, then you can use this to safely refer to a workbook regardless of extension:
Function GetWb(wbName As String)
Dim wb As Workbook, rv As Workbook
For Each wb In Application.Workbooks
If UCase(wb.Name) Like UCase(wbName & ".*") Then
Set rv = wb
Exit For
End If
Next wb
Set GetWb = rv
End Function
Usage
Dim destWb As Workbook
Set destWb = GetWb("file2")
if destWb Is Nothing then
Msgbox "destination file not open!"
else
'perform the copy
end if
FYI this may be why you see differences between computers:
Windows().Activate works on every computer except one
Hello thanks for reading my question. I'm trying to import a lot of files into one workbook.
This portion of the scrip works once through the first workbook but crashes on the second workbook when it hits sheet three.
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Set tmpWb = ActiveWorkbook
For Each Sheet In tmpWb.Sheets
Range("A2").Select
If Range("A2").Value <> "" Then
sFileName = tmpWb.Name
sFileName = Replace(sFileName, ".xlsx", "")
Sheet.Name = sFileName
wbNew.Activate
Sheet.Copy After:=wbNew.Sheets(1)
Else
'do nothing
End If
tmpWb.Activate
On Error GoTo LastSheet
Worksheets(ActiveSheet.Index + 1).Select
LastSheet:
Next Sheet
Workbooks(Filename).Close
Filename = dir()
Loop
It's crashing at Worksheets(ActiveSheet.Index + 1).Select
with this error
Run-Time error 9 Subscript out of range
Done, took a bit of time to figure it out but this functions nicely now, there maybe another bug but it can be used to import files and sheets from the files into one workbook
Sub GetSheets()
Dim sFileName As String
Dim Path As String
Dim wbNew As Workbook
Dim tmpWb As Workbook
Dim tSheets As Long
Dim iSheets As Long
iSheets = 0
Set wbNew = gWrkBook() 'creat new workbook
Path = gGetFolder("Any default folder path")
If gSearch(Path, "\", "LastChar") > 0 Then
Path = Path + "\"
End If
Filename = dir(Path & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
Set tmpWb = ActiveWorkbook
tSheets = tmpWb.Worksheets.Count
If tSheets > 0 Then
iSheets = 1
tmpWb.Sheets(iSheets).Activate
For iSheets = 1 To tSheets
tmpWb.Sheets(iSheets).Activate
Range("A2").Select
If Range("A2").Value <> "" Then
sFileName = tmpWb.Name + "-" + CStr(iSheets)
sFileName = Replace(sFileName, ".xlsx", "")
tmpWb.Sheets(iSheets).Name = sFileName
wbNew.Activate
tmpWb.Sheets(iSheets).Copy After:=wbNew.Sheets(1)
Else
End If
tmpWb.Activate
Next
End If
Workbooks(Filename).Close savechanges:=False
Filename = dir()
Loop
End Sub
Public Function gGetFolder(strPath As String) As String
Dim fldr As FileDialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
gGetFolder = sItem
Set fldr = Nothing
End Function
There is a ready script that counts number of rows in Workbooks from a selected folder. In case number of rows in any workbook is more than 1, this workbook is copied and saved into another folder.
Sub OpenFiles()
Dim MyFolder As String
Dim MyFile As String
Dim TargetWB As Workbook
MyFolder = GetFolder("C:\Users\user\Desktop")
MyFile = Dir(MyFolder & "*.*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While MyFile <> ""
Set TargetWB = Workbooks.Open(Filename:=MyFolder & "\" & MyFile & "*.*")
With TargetWB
If CountUsedRows(TargetWB) > 1 Then
.SaveAs "C:\Users\user\Desktop\vba\" & MyFile
End If
.Close
End With
MyFile = Dir
Loop
'Workbooks.Close savechanges:=False
Shell "explorer.exe C:\Users\user\Desktop\vba", vbMaximizedFocus
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function CountUsedRows(Wbk As Workbook) As Long
Dim WS As Worksheet
Set WS = Wbk.Sheets(1)
CountUsedRows = WS.Range("A" & Rows.Count).End(xlUp).Row
End Function
Is it possible to move a Worbook to another folder insted of coping it in case it contains more than 1 row.
And is it possible to use something like: Workbooks.Close savechanges:=False in order to close chosen Workbooks after rows counting? Thanks!
You can move a file easily using the MoveFile method of FileSystemObject object. To use this type with early binding add a reference to Microsoft Sripting Runtime in your VBA project.