Combining two Subs

[Petitboeuf]

Dear Experts,

I have two separate pieces of code create on two different Sub as pe
below:


Code
-------------------

Sub PromoTrack()

Dim Counter As Long
Dim Source As Workbook
Dim Destination As Workbook

Const MyDir As String = "c:\PromoTrack\MSA\"

Application.ScreenUpdating = False

For Counter = 7800 To 7809
Set Source = Workbooks.Open(MyDir & Counter & ".msa")
If Counter = 7800 Then
Source.Worksheets.Copy
Set Destination = ActiveWorkbook
ActiveSheet.Name = Counter
Else
Source.Worksheets.Copy After:=Destination.Worksheets(Destination.Worksheets.Count)
Destination.Worksheets(Destination.Worksheets.Count).Name = Counter
End If
Source.Close False
Next

Destination.SaveAs MyDir & "Summary.xls"

Application.ScreenUpdating = True

MsgBox "Done"

End Sub

-------------------



Code
-------------------

Sub ReadMSA()

Dim nCol, J, i As Integer

Workbooks.OpenText FileName:="C:\PromoTrack\MSA\7805.MSA"

nCol = 1

With ActiveSheet

For J = 1 To 80

If .Cells(J, nCol).Value = "lblProductCategory" Then
.Cells(J, nCol + 1).Select
.Cells(J, nCol + 1).Copy
Windows("PROMOPLANTRIAL.xls").Activate
Range("B1").Select
ActiveSheet.Paste
Windows("7805.MSA").Activate
End If

Etc… etc…

Next J

End With

End Sub

-------------------


Could you please let me know how to combine the two? I know there wil
be changes in ReadMSA() as I am not using the same variables. Bette
yet, can you help me re-write ReadMSA() so that it is fully integrate
in PromoTrack()?

I only want to copy the workbooks in PromoTrack() based on the conten
of the cell (B2) read via ReadMSA()

Does this makes sense?

Many thanks

 

[Petitboeuf]

Hiya...

Any chance of getting some help regarding the above?

I just want to put a condition for copying each worksheet... I've don
the following but get an error 91 on the save line...


Code
-------------------

Sub Blah()
Dim Counter As Long
Dim Source As Workbook
Dim Destination As Workbook
Dim R As Range


Const MyDir As String = "c:\PromoTrack\MSA\"

Application.ScreenUpdating = False

For Counter = 7800 To 7809
Set Source = Workbooks.Open(MyDir & Counter & ".msa")
Set R = Range("B2")

If R.Value = "Frozen and Chilled" Then

If Counter = 7800 Then
Source.Worksheets.Copy
Set Destination = ActiveWorkbook
ActiveSheet.Name = Counter
Else
Source.Worksheets.Copy After:=Destination.Worksheets(Destination.Worksheets.Count)
Destination.Worksheets(Destination.Worksheets.Count).Name = Counter
End If

End If

Source.Close False

Next

Destination.SaveAs MyDir & "Summary.xls"

Application.ScreenUpdating = True

MsgBox "Frozen MSAs compiled"

End Sub

 

[Dave Peterson]

It looks as though you might not be creating the destination workbook...

Option Explicit
Sub Blah()
Dim Counter As Long
Dim Source As Workbook
Dim Destination As Workbook
Dim R As Range

Const MyDir As String = "c:\PromoTrack\MSA\"

Application.ScreenUpdating = False

For Counter = 7800 To 7809
Set Source = Workbooks.Open(MyDir & Counter & ".msa")
Set R = Range("B2")
If R.Value = "Frozen and Chilled" Then
If Counter = 7800 Then
Source.Worksheets.Copy
Set Destination = ActiveWorkbook
ActiveSheet.Name = Counter
Else
Source.Worksheets.Copy _
After:=Destination.Worksheets _
(Destination.Worksheets.Count)
Destination.Worksheets(Destination.Worksheets.Count).Name _
= Counter
End If
End If
Source.Close False
Next Counter

If Destination Is Nothing Then
MsgBox "Nothing was copied"
Else
Destination.SaveAs MyDir & "Summary.xls"
End If

Application.ScreenUpdating = True

MsgBox "Frozen MSAs compiled"

End Sub

If the first file (7800) doesn't have "frozen and chilled", then you could have
trouble.

But that may not be the current problem.

 

[Petitboeuf]

Dave

Thanks a lot for the reply.

7800 has indeed got Frozen and Chilled in cell B2... so it shoul
trigger the worksheet to be copied into Summary.xls...

I get both messages now LOL and no Summary.xls... :

 

[Dave Peterson]

If you get that "Nothing was copied", then either 7800 doesn't have "frozen and
chilled" in it or you don't have a workbook that includes that number.

Maybe it'll be as simple as:

If lcase(R.Value) = lcase("Frozen and Chilled") Then

Or extra spaces or other typos????

 

[Petitboeuf]

.... Destination = Nothing.

So why does it not create/keep the workbook as previously set?

Frozen and Chilled is in 5 of the 8 workbooks that I open, including
number 7800...


Very confused.....

 

[Dave Peterson]

You may think that you're creating that workbook, but I don't think you are (and
neither does excel!):

I bet if you added a message box:

....
If Counter = 7800 Then
MsgBox "Creating the new workbook!"
Source.Worksheets.Copy
Set Destination = ActiveWorkbook
ActiveSheet.Name = Counter
Else
....

You'd never see that msgbox.

An alternative is to create the workbook first and then just copy the sheets
into that new workbook.

First, I don't know what a .msa file is. Are you sure it's opening correctly?

This has a few msgboxes that may help you find the problem:

Option Explicit
Sub Blah()
Dim Counter As Long
Dim Source As Workbook
Dim Destination As Workbook
Dim R As Range

Const MyDir As String = "c:\PromoTrack\MSA\"

Application.ScreenUpdating = False

Set Destination = Workbooks.Add(1) 'single sheet
Destination.Worksheets(1).Name = "DeleteMeLater"

For Counter = 7800 To 7809
Set Source = Workbooks.Open(MyDir & Counter & ".msa")
Set R = Source.Worksheets(1).Range("B2")
If LCase(Trim(R.Value)) = LCase(Trim("Frozen and Chilled")) Then
'for testing only:
MsgBox "copying: " & Source.FullName

'copy just the first worksheet?
With Destination
Source.Worksheets(1).Copy _
After:=.Worksheets(.Worksheets.Count)
.Worksheets(.Worksheets.Count).Name = Counter
End With
Else
'just for testing
MsgBox "Not copying: " & Source.FullName
End If
Source.Close savechanges:=False
Next Counter

If Destination.Worksheets.Count = 1 Then
'only that dummy sheet is there
MsgBox "Nothing was copied"
Destination.Close savechanges:=False
Else
Application.DisplayAlerts = False
Destination.Worksheets("deletemelater").Delete
Application.DisplayAlerts = True
Destination.SaveAs MyDir & "Summary.xls"
MsgBox "Frozen MSAs compiled and saved as: " & Destination.FullName
End If

Application.ScreenUpdating = True

End Sub