PDA

View Full Version : Error message when combining all excell wkbks in a folder using macro



eric.conwell
06-02-2008, 07:45 AM
I'm trying to combine several wkbs in a folder. I got the code from vbaexpress. It was under the article " Combine All Workbooks from One Folder Skipping Blank Sheets".

I'm using Excel 07.

When I use the following code I repeatedly get the following error in my vba when I try to debug:

WS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

Here is the complete code, any help would be great.

Option Explicit

'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal _
pszpath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) _
As Long

Public Type BrowseInfo
hOwner As Long
pIDLRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Function GetDirectory(Optional msg) As String
On Error Resume Next
Dim bInfo As BrowseInfo
Dim path As String
Dim r As Long, x As Long, pos As Integer

'Root folder = Desktop
bInfo.pIDLRoot = 0&

'Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Please select the folder of the excel files to copy."
Else
bInfo.lpszTitle = msg
End If

'Type of directory to return
bInfo.ulFlags = &H1

'Display the dialog
x = SHBrowseForFolder(bInfo)

'Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String

ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""
If FileName <> ThisWB Then
Set Wkb = Workbooks.Open(FileName:=path & "\" & 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 If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

Set Wkb = Nothing
Set LastCell = Nothing
End Sub

Bob Phillips
06-02-2008, 08:06 AM
Works fine for me, although you can get rid of the clumsy old API browse folder



Function GetDirectory(Optional msg) As String

With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then

GetDirectory = .SelectedItems(1)
End If
End With
End Function

Sub CombineFiles()
Dim path As String
Dim FileName As String
Dim LastCell As Range
Dim Wkb As Workbook
Dim WS As Worksheet
Dim ThisWB As String

ThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
If path <> "" Then

FileName = Dir(path & "\*.xls", vbNormal)
Do Until FileName = ""

If FileName <> ThisWB Then

Set Wkb = Workbooks.Open(FileName:=path & "\" & 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 If
FileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

Set Wkb = Nothing
Set LastCell = Nothing
End If
End Sub


Do you have anything unusual, do you know which workbook it fails on?

Oorang
06-02-2008, 08:20 AM
I was able to reproduce that error on hidden and very hidden worksheets. I also got an error when I tried to combine a password protect workbook. This will account for this issues:
Sub CombineFiles()
Dim path As String
Dim strFileName As String
Dim rngLastCell As Excel.Range
Dim wkb As Workbook
Dim ws As Worksheet
Dim strThisWB As String

strThisWB = ThisWorkbook.Name
Application.EnableEvents = False
Application.ScreenUpdating = False
path = GetDirectory
strFileName = Dir(path & "\*.xls", vbNormal)
Do Until Not CBool(LenB(strFileName))
If strFileName <> strThisWB Then
Set wkb = Nothing
On Error Resume Next
Set wkb = Workbooks.Open(FileName:=path & "\" & strFileName)
On Error GoTo 0
If Not wkb Is Nothing Then
For Each ws In wkb.Worksheets
Set rngLastCell = ws.Cells.SpecialCells(xlCellTypeLastCell)
If LenB(rngLastCell.Value) And rngLastCell.Address <> Range("$A$1").Address Then
If ws.Visible = xlSheetVisible Then
ws.Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count)
End If
End If
Next ws
wkb.Close False
End If
End If
strFileName = Dir()
Loop
Application.EnableEvents = True
Application.ScreenUpdating = True

Set wkb = Nothing
Set rngLastCell = Nothing
End Sub