Hey Ron there u go!! Please help. thanks. Also I was wondering do I need to
change the Module name to Get_Sheet_Macro, if so how do i do that. I tried to
but couldn't.
The code below I placed in Module1 that I created.
Sub RDB_Copy_Sheet()
Dim myFiles As Variant
Dim myCountOfFiles As Long
myCountOfFiles = Get_File_Names( _
MyPath:="C:\Documents and Settings\Desktop\Sample", _
Subfolders:=False, _
ExtStr:="*.xl*", _
myReturnedFiles:=myFiles)
If myCountOfFiles = 0 Then
MsgBox "No files that match the ExtStr in this folder"
Exit Sub
End If
Get_Sheet _
PasteAsValues:=True, _
SourceShName:="Profile", _
SourceShIndex:=2, _
myReturnedFiles:=myFiles
End Sub
' Note: You not have to change the macro below, you only
' edit and run the RDB_Copy_Sheet above.
Sub Get_Sheet(PasteAsValues As Boolean, SourceShName As String, _
SourceShIndex As Integer, myReturnedFiles As Variant)
Dim mybook As Workbook, BaseWks As Worksheet
Dim CalcMode As Long
Dim SourceSh As Variant
Dim sh As Worksheet
Dim I As Long
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
On Error GoTo ExitTheSub
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'Check if we use a named sheet or the index
If SourceShName = "" Then
SourceSh = SourceShIndex
Else
SourceSh = SourceShName
End If
'Loop through all files in the array(myFiles)
For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(myReturnedFiles(I))
On Error GoTo 0
If Not mybook Is Nothing Then
'Set sh and check if it is a valid
On Error Resume Next
Set sh = mybook.Sheets(SourceSh)
If Err.Number > 0 Then
Err.Clear
Set sh = Nothing
End If
On Error GoTo 0
If Not sh Is Nothing Then
sh.Copy
after:=BaseWks.Parent.Sheets(BaseWks.Parent.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = mybook.Name
On Error GoTo 0
If PasteAsValues = True Then
With ActiveSheet.UsedRange
.Value = .Value
End With
End If
End If
'Close the workbook without saving
mybook.Close savechanges:=False
End If
'Open the next workbook
Next I
' delete the first sheet in the workbook
Application.DisplayAlerts = False
On Error Resume Next
BaseWks.Delete
On Error GoTo 0
Application.DisplayAlerts = True
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
