Hi !

-Running Windows2k pro and Excel97

I work with two workbooks and want to export several worksheets from one
workbook to the other.

Here's my (BAD) code :

'================================================= ==================================
Sub TestExport()

Dim Source$, Destination$, SrcSheetName$()

ReDim SrcSheetsName$(1 To ActiveWorkbook.Worksheets.Count)
Source$ = ThisWorkbook.Name
Destination$ = "C:\Bulletins\3F\Bulletins3F.xls"

intPtr2 = 1
For intPtr1 = 1 To ActiveWorkbook.Worksheets.Count
strTemp1 = Right(Sheets(intPtr1).Name, 2)
If InStr(strTemp1, " P") Then
SrcSheetsName$(intPtr2) = Sheets(intPtr1).Name
intPtr2 = intPtr2 + 1
End If
Next intPtr1
intPtr2 = intPtr2 - 1

For intPtr1 = 1 To intPtr2
If SheetExists(Workbooks(Destination$).Sheets(SrcShee tsName$(intPtr1)))
Then
Workbooks(Destination$).Sheets(SrcSheetsName$(intP tr1)).Delete
End If
Workbooks(Source$).Sheets(SrcSheetsName$(intPtr1)) .Move
After:=Workbooks(Destination$).Sheets(1)
Next intPtr1

End Sub
'==============================
Public Function SheetExists(shtname As String) As Integer
Dim tptr%, tnbsheets%
SheetExists = 0
tnbsheets% = ActiveWorkbook.Worksheets.Count
For tptr% = 1 To tnbsheets%
If Worksheets(tptr%).Name = shtname Then
SheetExists = 1
Exit Function
End If
Next tptr%
End Function
'==============================



Question : how can I put that to work ??


Thanks by advance for your help and regards from Belgium,
Herve+

Try this:

Sub GroupSheetsToNewBook()
' This groups sheets with a specified name suffix and,
' moves them into a specified workbook.
' If the workbook isn't open, it opens it.
'
' Requires bBookIsOpen(), bFileExists() functions

Dim wks As Worksheet, wbkSource As Workbook, wbkTarget As Workbook
Dim Shts() As String, sPath As String, sName As String
Dim i As Integer
Dim bSheetsToMove As Boolean

Set wbkSource = ThisWorkbook

Application.ScreenUpdating = False

'Fill the array with names of sheets to move
i = 0
With wbkSource
For Each wks In .Worksheets
If UCase(Right(wks.Name, 2)) = " P" Then
'fill the array with names
ReDim Preserve Shts(0 To i)
Shts(i) = wks.Name
i = i + 1
bSheetsToMove = True
End If
Next
End With

'move the sheets into wbkTarget
If bSheetsToMove Then
sPath = "C:\Bulletins\3F\"
sName = "Bulletins3F.xls"

'Get a reference to wbkTarget
If Not bBookIsOpen(sName) Then
If bFileExists(sPath & sName) Then
Set wbkTarget = Workbooks.Open(sPath & sName)
Else
MsgBox "The target file does not exist !", vbExclamation + vbOKOnly
Exit Sub
End If
Else
Set wbkTarget = Workbooks(sName)
End If

wbkSource.Worksheets(Shts).Move
after:=wbkTarget.Sheets(wbkTarget.Sheets.Count)
With wbkTarget
.Save
.Close
End With
Else
MsgBox "There are no sheets to move !"
End If

End Sub


Function bBookIsOpen(wbkName) As Boolean
' Checks if a specified workbook is open.
'
' Arguments: wbkName [In] The name of the workbook
' Returns: True if the workbook is open

Const sSource As String = "bBookIsOpen()"

Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbkName)
bBookIsOpen = (Err = 0)
End Function


Function bFileExists(fileName As String) As Boolean
' Checks if a file exists in the specified folder
'
' Arguments: fileName [In] The fullname of the file
'
' Returns: TRUE if the file exists

Const sSource As String = "bFileExists()"

On Error Resume Next
bFileExists = (Dir$(fileName) < "")
End Function

Regards,
GS

Thank you : I have tried, but :
a) doesn't copy anything, although the array Shts() is filled correctly
b) locks everything with the 2 workbooks opened to the point you can't even
move the cursor into the vbe screen !

"GS" wrote:

Try this:

Sub GroupSheetsToNewBook()
' This groups sheets with a specified name suffix and,
' moves them into a specified workbook.
' If the workbook isn't open, it opens it.
'
' Requires bBookIsOpen(), bFileExists() functions

Dim wks As Worksheet, wbkSource As Workbook, wbkTarget As Workbook
Dim Shts() As String, sPath As String, sName As String
Dim i As Integer
Dim bSheetsToMove As Boolean

Set wbkSource = ThisWorkbook

Application.ScreenUpdating = False

'Fill the array with names of sheets to move
i = 0
With wbkSource
For Each wks In .Worksheets
If UCase(Right(wks.Name, 2)) = " P" Then
'fill the array with names
ReDim Preserve Shts(0 To i)
Shts(i) = wks.Name
i = i + 1
bSheetsToMove = True
End If
Next
End With

'move the sheets into wbkTarget
If bSheetsToMove Then
sPath = "C:\Bulletins\3F\"
sName = "Bulletins3F.xls"

'Get a reference to wbkTarget
If Not bBookIsOpen(sName) Then
If bFileExists(sPath & sName) Then
Set wbkTarget = Workbooks.Open(sPath & sName)
Else
MsgBox "The target file does not exist !", vbExclamation + vbOKOnly
Exit Sub
End If
Else
Set wbkTarget = Workbooks(sName)
End If

wbkSource.Worksheets(Shts).Move
after:=wbkTarget.Sheets(wbkTarget.Sheets.Count)
With wbkTarget
.Save
.Close
End With
Else
MsgBox "There are no sheets to move !"
End If

End Sub


Function bBookIsOpen(wbkName) As Boolean
' Checks if a specified workbook is open.
'
' Arguments: wbkName [In] The name of the workbook
' Returns: True if the workbook is open

Const sSource As String = "bBookIsOpen()"

Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbkName)
bBookIsOpen = (Err = 0)
End Function


Function bFileExists(fileName As String) As Boolean
' Checks if a file exists in the specified folder
'
' Arguments: fileName [In] The fullname of the file
'
' Returns: TRUE if the file exists

Const sSource As String = "bFileExists()"

On Error Resume Next
bFileExists = (Dir$(fileName) < "")
End Function

Regards,
GS

Hi,

Is wbkSource protected maybe?

I also noted that the line of code that moves the sheet did a text wrap in
the post. Make sure it's one continuous line, or put a line continuation
character in it as follows:

wbkSource.Worksheets(Shts).Move _
after:=wbkTarget.Sheets(wbkTarget.Sheets.Count)

Otherwise, it worked for me when I tested it with dummy files.

Regards,
GS


"affordsol" wrote:

Thank you : I have tried, but :
a) doesn't copy anything, although the array Shts() is filled correctly
b) locks everything with the 2 workbooks opened to the point you can't even
move the cursor into the vbe screen !

Hello,

I have tried the script with several workbooks and it works perfectly.

However, whenever I apply it to my complete workbook which has plenty of
sheets,
the problem is always the same:
as soon as the destination workbook (which has NO VBA code at all : just
sheets WITHOUT ANY link) is opened, the VBA stops working and the window
affixes the destination workbook.

If I hand select the source workbook, everything works but this is useless
for a dummy user who sees averything frozen and stays in the destination
workbook.

I really do not know what to do ...

"GS" wrote:

Hi,

Is wbkSource protected maybe?

I also noted that the line of code that moves the sheet did a text wrap in
the post. Make sure it's one continuous line, or put a line continuation
character in it as follows:

wbkSource.Worksheets(Shts).Move _
after:=wbkTarget.Sheets(wbkTarget.Sheets.Count)

Otherwise, it worked for me when I tested it with dummy files.

Regards,
GS


"affordsol" wrote:

Thank you : I have tried, but :
a) doesn't copy anything, although the array Shts() is filled correctly
b) locks everything with the 2 workbooks opened to the point you can't even
move the cursor into the vbe screen !