copying worksheets

[aoc]

hi,

how can I copy all worksheets in different workbooks in different subfolders into one workbook ?

regards

[lucas]

This might be a starting point from the knowledge base. Joseph's entry will combine all workbooks to into one from one folder.

[aoc]

hi,

I know that code, but do not know how to revise it to search subfolders as well

[mdmackillop]

This is a combination of this KB Item
and some of Joseph's code.

[VBA] 'Code goes in a standard module
'''''MUST SET REFERENCE to WINDOWS SCRIPT HOST OBJECT MODEL''''''''''''

Option Explicit

Sub PopulateDirectoryList()
'dimension variables
Dim objFSO As FileSystemObject, objFolder As Folder
Dim objFile As File, strSourceFolder As String, x As Long, i As Long
Dim wbNew As Workbook, wsNew As Worksheet

ToggleStuff False 'turn of screenupdating

Set objFSO = New FileSystemObject 'set a new object in memory
strSourceFolder = BrowseForFolder 'call up the browse for folder routine
If strSourceFolder = "" Then Exit Sub

Workbooks.Add 'create a new workbook


With Application.FileSearch
.LookIn = strSourceFolder 'look in the folder browsed to
.FileType = msoFileTypeAllFiles 'get all files
.SearchSubFolders = True 'search sub directories
.Execute 'run the search

For x = 1 To .FoundFiles.Count 'for each file found, by the count (or index)
i = x 'make the variable i = x
If x > 60000 Then 'if there happens to be more than multipls of 60,000 files, then add a new sheet
i = x - 60000 'set i to the right number for row placement below
Set wsNew = wbNew.Sheets.Add(After:=Sheets(wsNew.Index))
With wsNew.Range("A1:F1")
.Value = Array("File", "Parent Folder", "Full Path", "Modified Date", _
"Last Accessed", "Size")
.Interior.ColorIndex = 7
.Font.Bold = True
.Font.Size = 12
End With

End If
On Error GoTo Skip 'in the event of a permissions error

Set objFile = objFSO.GetFile(.FoundFiles(x)) 'set the object to get it's properties
'********************
If UCase(Right(objFile, 3)) = "XLS" Then Combines objFile

' Next objFile
Skip:
'this is in case a Permission denied error comes up or an unforeseen error
'Do nothing, just go to next file
Next x

End With

'clear the variables
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Set wsNew = Nothing
Set wbNew = Nothing

ToggleStuff True 'turn events back on
End Sub
Sub ToggleStuff(ByVal x As Boolean)
Application.ScreenUpdating = x
Application.EnableEvents = x
End Sub


Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'''Code from kpuls, www.VBAExpress.com..portion of Knowledge base submission
''www.codeguru.com

Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

Set ShellApp = Nothing

Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function

Invalid:


ToggleStuff True
End Function

Sub Combines(FileName)
Dim wkb As Workbook, WS As Worksheet, LastCell As Range
Set wkb = Workbooks.Open(FileName)
For Each WS In wkb.Worksheets
Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)
If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then
Else
WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
End If
Next WS
wkb.Close False

End Sub
[/VBA]

[aoc]

hi,

thanks for above code.but I get the error code some time later it runs
"too many different cell style"

If I want to see only links for each sheet that I can click and open the workbook, u know the code ?

[lucas]

Hi aoc,
What error do you get as this runs perfectly for me.....

[aoc]

hi,

maybe because of same sheet names ?
error : "too many different cell format"

I decided to use below code insted of above. I will see the names as link, I will try it in my company as the files are in the server.

Dim i As Integer 'Used in loop.
Dim wbResults As Workbook 'Name of workbook found
Dim wbCodeBook As Workbook 'Name of this workbook
Dim wSheet As Worksheet 'WorkSheet in found WorkBook
Dim mySearchPath As String 'Search Path
Dim mySearchPathLgth As Integer 'Length of path string used in Mid() function

Sub GetAllWorksheetNames()

On Error Resume Next

'Change the mySearchPath line to match the path
'where you want to search.
'Ensure the quotes (inverted commas) remain at each end.

mySearchPath = "D:\folder"

Sheets(1).Select

'Clear the sheet of all existing data
Cells.Select
Selection.Clear

'Insert column titles
Range("A1") = "Work Book Name"
Range("B1") = "Work Sheet Name"
Range("C1") = "Hyperlink"
Range("A1:C1").Font.Bold = True
Range("A1").Select

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Length of search path + 1 used to find next
'character in the mid()function used to find
'the worksheet name from the full path.
mySearchPathLgth = Len(mySearchPath) + 2

'Save Search Path for use in Hyperlinks.
'Can be saved anywhere but change the R1C27 in the
'Hyperlink code to match the row and column where saved.
'NOTE: R1C27 is Row 1 column 27 (same as cell AA1 but use
'R1C27 format in the hyperlink formula.
Sheets(1).Range("AA1") = mySearchPath & "\"

Set wbCodeBook = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = mySearchPath
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then ' 0 Then files of required type exist

For i = 1 To .FoundFiles.Count
Set wbResults = Workbooks.Open(.FoundFiles(i))
For Each wSheet In wbResults.Worksheets

'Write WorkBook Name to column 1
wbCodeBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2, 1) _
= Mid(.FoundFiles(i), mySearchPathLgth)

'Write the WorkSheet Name to column 2
wbCodeBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(1, 2) _
= wSheet.Name

'Write Hyperlink to column 3
'Hyperlink code. If cell address where the path
'is saved has been changed then the first
'address (R1C27)must be changed to match.

'NOTE: the section of this code with the inverted commas
'(quotes) must be on one line. You cannot break this
'section of code with an underscore.
wbCodeBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(1, 3).FormulaR1C1 = _
"=HYPERLINK(""[""&R1C27&RC[-2]&""]""&RC[-1]&""!A1"",""Open Sheet ""&RC[-1])"


Next wSheet
'Close the found workbook
wbResults.Close SaveChanges:=False
Next i
End If
End With

On Error GoTo 0

'Auto size columns for the data
Sheets(1).Select
Columns("A:C").Select
Selection.Columns.AutoFit

'Finalize
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub