PDA

View Full Version : Solved: move sheets from specific files each time a macro runs



aravindhan_3
11-04-2009, 06:11 AM
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.

GTO
11-05-2009, 12:58 AM
Hi Arvind,

If I am unserstanding correctly,

In a Standard Module:

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


Hope that helps,

Mark

aravindhan_3
11-05-2009, 03:11 AM
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

GTO
11-05-2009, 05:08 AM
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.

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


Hope that helps,

Mark

aravindhan_3
11-09-2009, 07:57 AM
Hi,

Thanks for your help its working....
thanks a million once again..

Arvind

aravindhan_3
11-10-2009, 07:07 AM
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

GTO
11-10-2009, 01:14 PM
Hi Arvind,

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 = 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


Hope that helps,

Mark

aravindhan_3
11-24-2009, 03:59 AM
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

GTO
11-24-2009, 10:30 PM
Hi Arvind,

Sorry about that. I would have thought that:


wbSource.Close False
ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value _
= ThisWorkbook.Worksheets(rCell.Offset(, 1).Value).UsedRange.Value


...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.

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