Browse Folder and copy sheet to active sheet

[Legacy 233604]

Hi Everyone,

I am new to excel programming. I found a great example of a similiar macro on this site that copies sheet1 from all files in this directory. I would like to add a couple of new features to this code:

1). I would like the user to browse to a directory for the source files. (I have example macro code for this as well).
2). The source worksbooks and the destination workbook will not be in the same directory. However, the destination workbook would be the active workbook.
3). I would like to put the copied data, from the folder of source workbooks, into the destination workbook (active) after a worksheet that is named hours.

I have tried several things and need help combing the 2 macros together.

Here are the two macros:
Sub CopySheeet1FromAllExcelFilesInThisFilesDirectory()
'Note last row of data in each Sheet1 is presumed to be the
'last row of Column A with data in it.

Dim strFileDirectory As String
Dim strFileName As String
Dim iAnswer As Integer
Dim intFileCount As Integer
Dim lNextWriteRow As Long
Dim sError As String
Dim sReport As String
Dim lX As Long
Dim bFound As Boolean
Dim lLastDataRow As Long
Dim iVisibleWindows As Integer
Dim sPreface As String
Dim lNextSummaryWriteRow As Long
Dim lLinesCopied As Long

'This workbook saved?
If ThisWorkbook.Path = "" Then
MsgBox "Save this file in the desired directory before continuing"
GoTo End_Sub
End If

For lX = 1 To Sheets.Count
If Worksheets(lX).Name = "Sheet1" Then
bFound = True
Exit For
End If
Next
If Not bFound Then Worksheets.Add(before:=Sheets(1)).Name = "Sheet1"

bFound = False
For lX = 1 To Sheets.Count
If Worksheets(lX).Name = "Summary" Then
bFound = True
Exit For
End If
Next
If Not bFound Then Worksheets.Add(after:=Sheets("Sheet1")).Name = "Summary"

'Close other workbooks - they may be ones we want to process
'and we don't want to overwrite them.
If Windows.Count > 1 Then
iAnswer = MsgBox("Close other workbooks and continue?" & vbCrLf & _
" OK to close all other workbooks and continue, or" & vbCrLf & _
" Cancel to stop this macro.", vbOKCancel + _
vbDefaultButton2 + vbExclamation, "Continue ?")
End If
If iAnswer = vbCancel Then
GoTo End_Sub
Else
iVisibleWindows = Windows.Count
For lX = Windows.Count To 1 Step -1
If Windows(lX).Caption <> ThisWorkbook.Name Then
If Windows(lX).Visible Then
'if workbook modified user will get
'chance to save or cancel for each
Windows(lX).Close
End If
iVisibleWindows = iVisibleWindows - 1
End If
Next
End If

strFileDirectory = ThisWorkbook.Path & "\"
'See if user chose Cancel for any close requests
If iVisibleWindows > 1 Then
MsgBox "Other Excel workbooks are still open. " & _
"Close other workbooks and try again", , "Process Cancelled."
GoTo End_Sub
End If

'More than this .xls file in the directory?
strFileName = Dir(strFileDirectory & "*.xls", 1)
Do While strFileName <> ""
intFileCount = intFileCount + 1
strFileName = Dir
Loop
If intFileCount = 1 Then
MsgBox "There are no other Excel files in the specified directory: " & vbCrLf & _
" " & strFileDirectory & vbCrLf & _
"There is nothing to process.", , "No Excel Files"
GoTo End_Sub
End If

iAnswer = MsgBox("All data on worksheets: 'Sheet1' and 'Summary' will be deleted. Continue?", vbOKCancel, "Clear Sheet1?")
If iAnswer = vbOK Then

MsgBox "DO NOT ENABLE MACROS IN ANY FILE THAT YOU ARE UNSURE OF" & vbLf & vbLf & _
"If you are prompted to enable macros for any file then you must do so for this process to complete." & vbLf & vbLf & _
"DO NOT ENABLE MACROS IN ANY FILE THAT YOU ARE UNSURE OF"

With ThisWorkbook.Worksheets("Sheet1")
.UsedRange.Clear
For lX = .Shapes.Count To 1 Step -1
.Shapes(lX).Delete
Next
End With
ThisWorkbook.Worksheets("Summary").UsedRange.Clear

lNextWriteRow = 1
lNextSummaryWriteRow = 2
Worksheets("Summary").Range("A1").Resize(1, 4).Value = Array("WorkBook Copied", "# Lines", "", "Total Lines Copied")

'Process other workbooks
strFileName = Dir(strFileDirectory & "*.xls?", 1)
Do While strFileName <> ""
If UCase(strFileName) <> UCase(ThisWorkbook.Name) And _
UCase(strFileName) <> "PERSONAL.XLS" And _
strFileName <> "PERSONAL.XLSM" Then
bFound = False
Workbooks.Open Filename:=strFileDirectory & strFileName

'Process file
For lX = 1 To Worksheets.Count
If Worksheets(lX).Name = "Sheet1" Then
bFound = True
Exit For
End If
Next
If bFound Then
Worksheets("sheet1").Activate
Range("A1").Select 'in case workbook was saved with an object selected
lLastDataRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet1").Rows("1:" & lLastDataRow).Copy Destination:=ThisWorkbook.Sheets("Sheet1").Cells(lNextWriteRow, 1)
sReport = sReport & vbLf & lLastDataRow & vbTab & ActiveWorkbook.Name
ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 1) = strFileName
ThisWorkbook.Worksheets("Summary").Cells(lNextSummaryWriteRow, 2) = lLastDataRow
lNextSummaryWriteRow = lNextSummaryWriteRow + 1
lLinesCopied = lLinesCopied + lLastDataRow
Else
sError = sError & vbLf & ActiveWorkbook.Name
End If

ActiveWorkbook.Saved = True
Windows(strFileName).Close
End If
strFileName = Dir
lNextWriteRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
With ThisWorkbook.Worksheets("Summary")
.Columns("A:D").EntireColumn.AutoFit
.Range("A1").Activate
End With

Loop

ThisWorkbook.Worksheets("Summary").Cells(2, 4) = lLinesCopied

sPreface = "For directory: " & ThisWorkbook.Path & vbLf & vbLf
If sReport <> "" Then sReport = sReport & vbLf & "------" & vbLf & _
lLinesCopied & vbTab & "Total Lines Copied"
If sError <> "" Then sReport = sReport & vbLf & vbLf & _
"The following workbooks did not contain a worksheet named 'Sheet1':" & vbLf
MsgBox sPreface & "Rows" & vbTab & "Copied from 'Sheet1'" & vbLf & "1 thru" & vbTab & " in each of these workbooks:" & vbLf & _
sReport & sError
Sheets("Sheet1").Copy
With ThisWorkbook.Worksheets("Sheet1")
.UsedRange.Clear
For lX = .Shapes.Count To 1 Step -1
.Shapes(lX).Delete
Next
End With
Else
MsgBox "Process Cancelled"
End If
End_Sub:
End Sub

Option Explicit
Sub RDB_Merge_Data_Browse()
Dim myFiles As Variant
Dim myCountOfFiles As Long
Dim oApp As Object
Dim oFolder As Variant
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512)
If Not oFolder Is Nothing Then
myCountOfFiles = Get_File_Names( _
MyPath:=oFolder.Self.Path, _
Subfolders:=False, _
ExtStr:="*.xl*", _
myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If
End If
End Sub

 

[Andrew Poulsom]

Welcome to MrExcel.

Maybe this will help you:

Merge data from all workbooks in a folder (1)

The procedure Basic_Example_2 prompts for the folder.

 

[Legacy 233604]

Yes, I have that code in the second macro:
Option Explicit
Sub RDB_Merge_Data_Browse()
Dim myFiles As Variant
Dim myCountOfFiles As Long
Dim oApp As Object
Dim oFolder As Variant
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512)
If Not oFolder Is Nothing Then
myCountOfFiles = Get_File_Names( _
MyPath:=oFolder.Self.Path, _
Subfolders:=False, _
ExtStr:="*.xl*", _
myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If
End If
End Sub

 

[Andrew Poulsom]

Yes, but you don't appear to be using it.

 

[Legacy 233604]

Yes, I tried that example Macro. It kind of works but, I'm having some issues with the formatting. I thought the other macro was better to start with. But, I can go back to this one.

Ok. Now, there are 5 things wrong that need to be fixed.

1). It is printing out a list of file names in column A and I don't really need that.

2). It's creating a new workbook with a spreadsheet
I would like to have the data copied over to the workbook that I have open, which is called example.xlsm.

4). I would like the data copied to the destination workbook (active) after a tab named "Hours".

5). The source spreadsheets that I want to copy data from have the same identical number of columns, but a different rows.

For example, 1 of the source spreadsheets may have 600 rows and another may have 24.

I changed the code Basic_Example_2() range to A12:G12 in the lines:
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:AD600")


If someone could help me with these 5 things, I will be golden.

Thanks
Anne

Here is the Basic_Example 2 code that I am now working with.

#If VBA7 Then
Declare PtrSafe Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#Else
Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
#End If

Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub Basic_Example_2()
Dim MyPath As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\Users"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1

'Loop through all files in the array(myFiles)
For Fnum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
Set sourceRange = .Range("A1:AD600")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
End Sub