Hi,
Thanks for your help..
I would really appreciate very much if you could help me on this.
I have several files saved on a folder called 'Files' and I have one master file in another folder.
I need to get some sheets from all the files in 'Files' folder and move those to my master excel file.
note: I have enter the path and file names in column 'b' and sheet names in column 'C' to be imported to my Master file.
I have attached an example with details.
Thanks for your help again.
Hi Arvind,
If I am unserstanding correctly,
In a Standard Module:
[vba]
Option Explicit
Sub OverwriteOldSheets()
Dim _
FSO As Object, _
wbSource As Workbook, _
wksSource As Worksheet, _
rngLastFile As Range, _
rngFileList As Range, _
rCell As Range, _
lLRow As Long, _
lIndex As Long
Const START_ROW As Long = 2 '<--- To allow for header row, change to suit.
'// Set a reference to FSO so we can use .FileExists to make sure we're trying //
'// to open a file/wb that exists. //
Set FSO = CreateObject("Scripting.FileSystemObject")
'// As the sheet with the fullnames shouldn't change, we can use the codename, //
'// which in your example wb is Sheet2. //
With Sheet2
'// Find the last fullname in Col B //
Set rngLastFile = .Range("B2:B" & Rows.Count).Find(What:="*", _
After:=.Cells(2, 2), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
'// On the chance we've forgotten to put some fullnames in, prevent an error//
'// by bailing here. //
If rngLastFile Is Nothing Then Exit Sub
'// ...else we can proceed... //
'// Set our range of fullnames. //
Set rngFileList = .Range("B" & START_ROW & ":" & "B" & rngLastFile.Row)
For Each rCell In rngFileList
'// Make sure the cell isn't empty and that the file/wb exists. //
If Not rCell.Value = vbNullString _
And FSO.FileExists(rCell.Value) Then
'// Set a reference to the wb as we open it... //
Set wbSource = Workbooks.Open(rCell.Value, , True)
With wbSource
'// ...then attempt to set a reference to the sheet we want. //
Set wksSource = wbSource.Worksheets(rCell.Offset(, 1).Value)
'// If the sheet we want exists... //
If Not wksSource Is Nothing Then
'// ...see if we already have a copy in this workbook, and //
'// if yes, where's it at; then delete the old one, OR, //
If ShExists(ThisWorkbook, rCell.Offset(, 1).Value) Then
lIndex = ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Index
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Delete
Application.DisplayAlerts = True
Else
'// ...if we don't already have a copy in thisworkbook, //
'// assign a val to lIndex, so we put the new copy at //
'// the end of our current worksheets. //
lIndex = ThisWorkbook.Worksheets.Count + 1
End If
'// Copy the sheet from Source to ThisWorkbook, then close //
'// source wb. //
If lIndex = 1 Then
wksSource.Copy Before:=ThisWorkbook.Worksheets(lIndex)
Else
wksSource.Copy After:=ThisWorkbook.Worksheets(lIndex - 1)
End If
wbSource.Close False
'// Get rid of any formulas. //
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value _
= ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value
Else
'// If we didn't find the sheet we were looking for in the source//
'// wb, close source wb and tell user. //
wbSource.Close False
MsgBox "No sheet named: " & rCell.Offset(, 1).Value
End If
End With
Else
'// In case we didn't find the wb, tell user. //
MsgBox "File: " & rCell.Value & vbCrLf & "does not exist"
End If
Next
End With
End Sub
Function ShExists(WB As Workbook, ShName As String) As Boolean
Dim wks As Worksheet
On Error Resume Next
Set wks = WB.Worksheets(ShName)
On Error GoTo 0
ShExists = CBool(Not wks Is Nothing)
End Function
[/vba]
Hope that helps,
Mark
Hi,
Thanks for your help... I ran this code but I am not any errors or the result, the macro runs and stops in a second...
could not find out the problem.
arvind
I forgot one error handling bit, but if it did not error (ie - found the sheets in the books, I do not see what could be going wrong.
Here's fixed code, workbook attached.
[vba]
Option Explicit
Sub OverwriteOldSheets()
Dim _
FSO As Object, _
wbSource As Workbook, _
wksSource As Worksheet, _
rngLastFile As Range, _
rngFileList As Range, _
rCell As Range, _
lLRow As Long, _
lIndex As Long
Const START_ROW As Long = 8 '<--- To allow for header row, change to suit.
Set FSO = CreateObject("Scripting.FileSystemObject")
With shtFileNames
Set rngLastFile = .Range("B2:B" & Rows.Count).Find(What:="*", _
After:=.Cells(2, 2), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rngLastFile Is Nothing Then Exit Sub
Set rngFileList = .Range("B" & START_ROW & ":" & "B" & rngLastFile.Row)
For Each rCell In rngFileList
If Not rCell.Value = vbNullString _
And FSO.FileExists(rCell.Value) Then
Set wbSource = Workbooks.Open(rCell.Value, , True)
With wbSource
'// PLEASE NOTE: //
'// This needs included... //
On Error Resume Next
Set wksSource = .Worksheets(rCell.Offset(, 1).Value)
On Error GoTo 0
If Not wksSource Is Nothing Then
If ShExists(ThisWorkbook, rCell.Offset(, 1).Value) Then
lIndex = ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Index
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Delete
Application.DisplayAlerts = True
Else
lIndex = ThisWorkbook.Worksheets.Count + 1
End If
If lIndex = 1 Then
wksSource.Copy Before:=ThisWorkbook.Worksheets(lIndex)
Else
wksSource.Copy After:=ThisWorkbook.Worksheets(lIndex - 1)
End If
wbSource.Close False
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value _
= ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value
Else
wbSource.Close False
MsgBox "No sheet named: " & rCell.Offset(, 1).Value
End If
End With
Else
MsgBox "File: " & rCell.Value & vbCrLf & "does not exist"
End If
Next
End With
End Sub
Function ShExists(WB As Workbook, ShName As String) As Boolean
Dim wks As Worksheet
On Error Resume Next
Set wks = WB.Worksheets(ShName)
On Error GoTo 0
ShExists = CBool(Not wks Is Nothing)
End Function
[/vba]
Hope that helps,
Mark
Hi,
Thanks for your help its working....
thanks a million once again..
Arvind
Hi,
Sorry for continuing from the solved thread, Is it possible to make some changes on the code for getting data from password protected files?
Assume all the files which are there in Column B are password protected and I have the list of passwords for those files in column D.
Is it possible to give command in macro to use the passwords from column D for those files and then move the sheets.
Thanks for your help
Arvind
Hi Arvind,
Try:
[vba]
Option Explicit
Sub OverwriteOldSheets()
Dim _
FSO As Object, _
wbSource As Workbook, _
wksSource As Worksheet, _
rngLastFile As Range, _
rngFileList As Range, _
rCell As Range, _
lLRow As Long, _
lIndex As Long
Const START_ROW As Long = 2 '<--- To allow for header row, change to suit.
Set FSO = CreateObject("Scripting.FileSystemObject")
With shtFileNames
Set rngLastFile = .Range("B2:B" & Rows.Count).Find(What:="*", _
After:=.Cells(2, 2), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rngLastFile Is Nothing Then Exit Sub
Set rngFileList = .Range("B" & START_ROW & ":" & "B" & rngLastFile.Row)
For Each rCell In rngFileList
If Not rCell.Value = vbNullString _
And FSO.FileExists(rCell.Value) Then
'// Bypass any error for the moment, attempt to open the existing //
'// file with the password supplied. //
On Error Resume Next
Set wbSource = Workbooks.Open(Filename:=rCell.Value, _
ReadOnly:=True, _
Password:=rCell.Offset(, 2).Value)
'// In case of failure, advise user of said, clear error and jump //
'// to end of loop //
If Err.Number > 0 Then
MsgBox "Wrong pwd supplied for: " & rCell.Value, 0, vbNullString
Err.Clear
On Error GoTo 0
GoTo NextFile
End If
On Error GoTo 0
With wbSource
'// PLEASE NOTE: //
'// This needs included... //
On Error Resume Next
Set wksSource = .Worksheets(rCell.Offset(, 1).Value)
On Error GoTo 0
If Not wksSource Is Nothing Then
If ShExists(ThisWorkbook, rCell.Offset(, 1).Value) Then
lIndex = ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Index
Application.DisplayAlerts = False
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Delete
Application.DisplayAlerts = True
Else
lIndex = ThisWorkbook.Worksheets.Count + 1
End If
If lIndex = 1 Then
wksSource.Copy Before:=ThisWorkbook.Worksheets(lIndex)
Else
wksSource.Copy After:=ThisWorkbook.Worksheets(lIndex - 1)
End If
wbSource.Close False
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value _
= ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value
Else
wbSource.Close False
MsgBox "No sheet named: " & rCell.Offset(, 1).Value
End If
End With
Else
MsgBox "File: " & rCell.Value & vbCrLf & "does not exist"
End If
NextFile:
Next
End With
End Sub
Function ShExists(WB As Workbook, ShName As String) As Boolean
Dim wks As Worksheet
On Error Resume Next
Set wks = WB.Worksheets(ShName)
On Error GoTo 0
ShExists = CBool(Not wks Is Nothing)
End Function
[/vba]
Hope that helps,
Mark
Hi,
Thanks for you help its working fine for me, howeverever if the sheet has only values then it imports the sheet properly, if any of those sheet has formulas the values in these sheets are shows as #NAME?
Please help me to correct this
Thanks
Hi Arvind,
Sorry about that. I would have thought that:
...would have taken care of that. I admit that in the the test source files created, I simply used =Sheet3!A1:C3 in a block of cells to simulate formula results, and didn't have a problem.wbSource.Close False ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value _ = ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value
Anyone: Maybe I am missing something?
Anyways, not tested but with test copies of both source and destination file(s), maybe try:
Option Explicit Sub OverwriteOldSheets() Dim _ FSO As Object, _ wbSource As Workbook, _ wksSource As Worksheet, _ rngLastFile As Range, _ rngFileList As Range, _ rCell As Range, _ lLRow As Long, _ lIndex As Long Const START_ROW As Long = 11 '<--- To allow for header row, change to suit. Set FSO = CreateObject("Scripting.FileSystemObject") With shtFileNames Set rngLastFile = .Range("B2:B" & Rows.Count).Find(What:="*", _ After:=.Cells(2, 2), _ LookIn:=xlValues, _ LookAt:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious) If rngLastFile Is Nothing Then Exit Sub Set rngFileList = .Range("B" & START_ROW & ":" & "B" & rngLastFile.Row) For Each rCell In rngFileList If Not rCell.Value = vbNullString _ And FSO.FileExists(rCell.Value) Then '// Bypass any error for the moment, attempt to open the existing // '// file with the password supplied. // On Error Resume Next Set wbSource = Workbooks.Open(Filename:=rCell.Value, _ ReadOnly:=True, _ Password:=rCell.Offset(, 2).Value) '// In case of failure, advise user of said, clear error and jump // '// to end of loop // If Err.Number > 0 Then MsgBox "Wrong pwd supplied for: " & rCell.Value, 0, vbNullString Err.Clear On Error GoTo 0 GoTo NextFile End If On Error GoTo 0 With wbSource '// PLEASE NOTE: // '// This needs included... // On Error Resume Next Set wksSource = .Worksheets(rCell.Offset(, 1).Value) On Error GoTo 0 If Not wksSource Is Nothing Then If ShExists(ThisWorkbook, rCell.Offset(, 1).Value) Then lIndex = ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Index Application.DisplayAlerts = False ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).Delete Application.DisplayAlerts = True Else lIndex = ThisWorkbook.Worksheets.Count + 1 End If '//Try adding // wksSource.UsedRange.Value = wksSource.UsedRange.Value If lIndex = 1 Then wksSource.Copy Before:=ThisWorkbook.Worksheets(lIndex) Else wksSource.Copy After:=ThisWorkbook.Worksheets(lIndex - 1) End If wbSource.Close False '// and skipping... // 'ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value _ = ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value Else wbSource.Close False MsgBox "No sheet named: " & rCell.Offset(, 1).Value End If End With Else MsgBox "File: " & rCell.Value & vbCrLf & "does not exist" End If NextFile: Next End With End Sub Function ShExists(WB As Workbook, ShName As String) As Boolean Dim wks As Worksheet On Error Resume Next Set wks = WB.Worksheets(ShName) On Error GoTo 0 ShExists = CBool(Not wks Is Nothing) End Function
Does that work?
Mark
Posting Permissions
Reply With Quote
