Macro to copy sheets from multiple workbooks

[petes]

Hi Friends!!

I have one Master file (MAIN.xlsx) and other files (A.xslx, B.xslx, C.xslx........). All these files are in the same folder (C:\test)

I need a macro in MAIN.xlsx file, so that it should copy all the data only from sheet1 of other files (A.xslx, B.xslx, C.xslx........) and paste it after the sheet1 of MAIN.xlsx file along with their sheet names.

Also, the other files (A.xslx, B.xslx, C.xslx........) should be closed after this operation.

Your help is very much appreciated...!!

 

[petes]

humm....
1) Msg box is not appearing when I select the (Master.xls) file. it is displaying (Already Opened Error.......)

2) The other file which I want to copy from is throwing an error when it is Open (Already Opened Error.......) and not when it is closed

any thoughts??

 

[VoG]

Try

Sub openfile()
Dim sFil As String
Dim sTitle As String
Dim sWb As Variant
Dim aWb As Variant
Dim iFilterIndex As Integer
With Application
    .ScreenUpdating = False
    ' Set up list of file filters
    sFil = "Excel Files (*.xls),*.xls"
    ' Display *.xls by default
    iFilterIndex = 1
    ' Set the dialog box caption
    sTitle = "Select File to Open"
    ' Get the filename
    sWb = Application.GetOpenFilename(sFil, iFilterIndex, sTitle)
    If sWb = False Then GoTo exit_proc
    aWb = Right(sWb, Len(sWb) - InStrRev(sWb, "\"))
    If LCase(sWb) Like "*\master.*" Then
        MsgBox "Error: you cannot select " & aWb, vbExclamation
        GoTo exit_proc
    End If
    If Not BookOpen(aWb) Then
        Workbooks.Open Filename:=aWb
    Else
        Workbooks(aWb).Activate
    End If
    ActiveWorkbook.Sheets(1).UsedRange.Copy ThisWorkbook.Sheets("Operational_Tasks_Current").Range("A1")
    'close source workbook
    ActiveWorkbook.Close False
exit_proc:
    .ScreenUpdating = True
    .CutCopyMode = False
    
End With
Exit Sub
err_handler:
MsgBox "No selection made", vbCritical, "User Cancelled"
Resume exit_proc
End Sub

Function BookOpen(wbName As Variant) As Boolean
On Error Resume Next
BookOpen = Len(Workbooks(wbName).Name)
End Function

 

[petes]

2nd Problem is Resolved...Thanks (I am able to run eventhough the other workbook is open)...

But, when i select the Master.xls file and click open, it is actually closing the workbook and msg box is not appearing....

what i wanted is, user should get an msgbox (something like you cannot select master), and if the user selects any other file apart from Master, this should run normally..

I believe this is same thing that you are trying to code!! let me know

 

[VoG]

I tested it and it would not let me open master.xls due to this bit of code

    If LCase(sWb) Like "*\master.*" Then
        MsgBox "Error: you cannot select " & aWb, vbExclamation
        GoTo exit_proc
    End If

 

[petes]

I am Sorry... my mistake, I was working on something and mistakenly changed file name to Mastre...

Hats off to you... now it is absolutely fine... you made my day

Thanks again!!

 

[petes]

Hi Vog!! I am back to need help on some formula.

In Column A of Excel I have values like:

413.0-413.1 in A1
414.00-414.07 in A2
414.10-414.12 in A4

I need a formula in Column B that will display the Result as:

2 in B1 for A1
8 in B2 for A2
3 in B3 for A4

Actullay, the Result is the difference in figures between the hiphen (-) and adding 1 to it. Since if is the single cell, i am unable to put the formula

Any Thoughts??

 

[VoG]

Please start a new thread for this completely different question.

 

[petes]

true... that will be helpful for all.. I have submitted the new thread with different subject here.
http://www.mrexcel.com/forum/showthread.php?p=2846350#post2846350

 

[nkkhil]

Hi VoG,

I was wondering if you could help me i have been going through the various macros on this thread and work really well

Is there a way to modify any of them to only copy the data from 1 separate sheet to a sheet within the master file of the same name? Both sheets are identical in terms of number of cells etc its just it will ensure it retains the formatting of the destination sheet.

Any help would be greatly appreciated

 

[petes]

One more question similar to Merging..

I have this code that copies the data from Range B5 from all the workbooks that is there in the location c:\test1 along with their file names. However, this copies data only from Sheet 1.

I need to alter this code, so that it copies the data from Range B5 from all the worksheets.
Typically Range B5 is Static and Worksheets are dynamic.

Sub MergeAllWorkbooks()
Dim MyPath As String, FilesInPath As String
Dim MyFiles() 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
' Change this to the path\folder location of your files.
MyPath = "C:\test1"
' Add a slash at the end of the path if needed.
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
' If there are no Excel files in the folder, exit.
FilesInPath = Dir(MyPath & "*.xl*")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
' Fill the myFiles array with the list of Excel files
' in the search folder.
FNum = 0
Do While FilesInPath <> ""
FNum = FNum + 1
ReDim Preserve MyFiles(1 To FNum)
MyFiles(FNum) = FilesInPath
FilesInPath = Dir()
Loop
' Set various application properties.
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
' Add a new workbook with one sheet.
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
' Loop through all files in the myFiles array.
If FNum > 0 Then
For FNum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(FNum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
' Change this range to fit your own needs.
With mybook.Worksheets(1)
Set sourceRange = .Range("B5")
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
' If source range uses 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 "There are not enough rows in the target worksheet."
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 = MyFiles(FNum)
End With
' Set the destination range.
Set destrange = BaseWks.Range("B" & rnum)
' Copy the values from the source range
' to the destination range.
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 the application properties.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub