Merged code gives a Run Time Error

I

ipbr21054

Well-known Member
Joined
Nov 16, 2010
Messages
5,832
Office Version
  1. 2007
Platform
  1. Windows
Hi,

I have two buttons on my worksheet but would rather have only the one.
Thus meaning i need to merge the two codes together.

The two codes are shown below.
Once i run the code the first code runs & does whats its supposed to do but when doing the second part of the code i ger a run time error 13 Type Missmatch.
The text below is then shown in yellow.


Code: 
Private Sub GrassSummaryIncomeSheet_Click()    Dim strFileName As String
    
        strFileName = "C:\Users\Ian\Desktop\GRASS CUTTING\CURRENT GRASS SHEETS\INCOME 2019-2020\" & _
        Range("J3") & "_" & Format(Month(DateValue(Range("G3") & " 1, " & "2019")), "00") & " " & Range("G3") & ".pdf"


    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        Exit Sub
    End If
    
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS SAVED SUCCESSFULLY", vbInformation + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        Range("G5:H30").ClearContents
        Range("G5").Select
        ActiveWorkbook.Save
    End With


End Sub

Code: 
Private Sub TransferIncomeInfo_Click()    Dim rFndCell As Range
    Dim strData As String
    Dim stFnd As String
    Dim fRow As Long
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim strDate As String


    Set ws = Sheets("G INCOME")
    Set sh = Sheets("G SUMMARY")
    stFnd = ws.Range("G3").Value
    strDate = ws.Range("G5").Value
    With sh
        Set rFndCell = .Range("C5:C17").Find(stFnd, LookIn:=xlValues)
        If Not rFndCell Is Nothing Then
            fRow = rFndCell.Row
            If CDate(strDate) > CDate("05/04/2019") Then
                sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            Else:
                sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            End If
            MsgBox "Transfer Has Been Completed", vbInformation + vbOKOnly, "INCOME TRANSFER SHEET MESSAGE"
        Else
            MsgBox "DOES NOT EXIST"
        End If
    End With
End Sub

Ive merged them now & have this one piece of code shown.

Code: 
Option Explicit

Private Sub GrassSummaryIncomeSheet_Click()
    Dim strFileName As String
    
        strFileName = "C:\Users\Ian\Desktop\GRASS CUTTING\CURRENT GRASS SHEETS\INCOME 2019-2020\" & _
        Range("J3") & "_" & Format(Month(DateValue(Range("G3") & " 1, " & "2019")), "00") & " " & Range("G3") & ".pdf"


    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        Exit Sub
    End If
    
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS SAVED SUCCESSFULLY", vbInformation + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        Range("G5:H30").ClearContents
        Range("G5").Select
        ActiveWorkbook.Save
    End With
    
    Dim rFndCell As Range
    Dim strData As String
    Dim stFnd As String
    Dim fRow As Long
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim strDate As String


    Set ws = Sheets("G INCOME")
    Set sh = Sheets("G SUMMARY")
    stFnd = ws.Range("G3").Value
    strDate = ws.Range("G5").Value
    With sh
        Set rFndCell = .Range("C5:C17").Find(stFnd, LookIn:=xlValues)
        If Not rFndCell Is Nothing Then
            fRow = rFndCell.Row
[COLOR=#ff0000]            If CDate(strDate) > CDate("05/04/2019") Then[/COLOR]
                sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            Else:
                sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            End If
            MsgBox "Transfer Has Been Completed", vbInformation + vbOKOnly, "INCOME TRANSFER SHEET MESSAGE"
        Else
            MsgBox "DOES NOT EXIST"
        End If
    End With
End Sub
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Sort by date Sort by votes
If you have two separate codes that are working fine, there is no reason to combine them together. Just give them their own names, and have your button_click code call each one in succession.

For example, if you rename your procedures "Code1" and "Code2" (so they are no longer attached to button clicks), then your button click code could look like something like:

Code: 
Private Sub Button1_Click()
    Call Code1
    Call Code2
End Sub
 
Last edited:
Upvote 0
Hi,

Ive just tried that but fails on the same line of code.
 
Upvote 0
Think i found out why but need to check.
The second code is looking for a date in the first cell but the first code has just cleared it out.

Will reply back soon.
 
Upvote 0
Think i found out why but need to check.
The second code is looking for a date in the first cell but the first code has just cleared it out.

Will reply back soon.
Click to expand...
Yes, you would need to check to make sure that the codes don't interfere with each other and make the necessary adjustments.
 
Upvote 0
Hi,
Yes that was the issue so the clearcontents code has now been moved so its cleared after the second code has run BUT i now see another issue.

I have this in place.
Code: 
Private Sub TransferButton_Click()Call INCOMETRANSFER
Call SUMMARYTRANSFER
End Sub

The Income transfer shows the msg box ALREADY EXISTS etc should the pdf exist,so in my test obviously it does.
I then click on OK then i see the Summary Transfer continue.

Is there something we can do so if the msg box is shown in the first code then abort the second code from running.

Thanks
 
Upvote 0
So you need to get a value from the first procedure and use it in the second.
One way is to create a global variable, then set its value in the first procedure and check it before running the second procedure.
Here is a link that shows you how to declare a Global variable: https://www.excel-easy.com/vba/examples/variable-scope.html

So, at the top of your module, you would have this (above your first procedure):
Code: 
Public PDFExists As Boolean
Then you would amend your button code like this:
Code: 
Private Sub TransferButton_Click()
    
    Call INCOMETRANSFER
    
    If PDFExists Then
'       Do nothing
    Else
        Call SUMMARYTRANSFER
    End If
    
End Sub
And update the block in your first code to see if the file already exists like this (need parts highlighted in red text):
Code: 
Private Sub INCOMETRANSFER()
    
'   beginning of code...

    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        [COLOR=#ff0000]PDFExists = True[/COLOR]
        Exit Sub
[COLOR=#ff0000]    Else
        PDFExists = False[/COLOR]
    End If

'   rest of code....

End Sub
 
Upvote 0
I cant quite follow that info on that link but looked at your info above.

This is what i have but not sure about the module part of it.

First code is called INCOMETRANSFER

Code: 
Private Sub INCOMETRANSFER()    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        PDFExists = True
        Exit Sub
    Else
        PDFExists = False
    End If
    Dim strFileName As String
    
        strFileName = "C:\Users\Ian\Desktop\GRASS CUTTING\CURRENT GRASS SHEETS\INCOME 2019-2020\" & _
        Range("J3") & "_" & Format(Month(DateValue(Range("G3") & " 1, " & "2019")), "00") & " " & Range("G3") & ".pdf"


    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        Exit Sub
    End If
    
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS SAVED SUCCESSFULLY", vbInformation + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"


    End With


End Sub

Second code is called SUMMARYTRANSFER

Code: 
Option ExplicitPrivate Sub SUMMARYTRANSFER()
    Dim rFndCell As Range
    Dim strData As String
    Dim stFnd As String
    Dim fRow As Long
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim strDate As String


    Set ws = Sheets("G INCOME")
    Set sh = Sheets("G SUMMARY")
    stFnd = ws.Range("G3").Value
    strDate = ws.Range("G5").Value
    With sh
        Set rFndCell = .Range("C5:C17").Find(stFnd, LookIn:=xlValues)
        If Not rFndCell Is Nothing Then
            fRow = rFndCell.Row
            If CDate(strDate) > CDate("05/04/2019") Then
                sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            Else:
                sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            End If
            MsgBox "Transfer To Summary Sheet Also Completed", vbInformation + vbOKOnly, "INCOME TRANSFER SHEET MESSAGE"
        Else
            MsgBox "DOES NOT EXIST"
        End If
        Range("G5:H30").ClearContents
        Range("G5").Select
        ActiveWorkbook.Save
    End With
End Sub

Code on button is,

Code: 
Private Sub TransferButton_Click()    
    Call INCOMETRANSFER
    
    If PDFExists Then
'       Do nothing
    Else
        Call SUMMARYTRANSFER
    End If
    
End Sub

Module 59 code is,
Public PDFExists As Boolean
 
Upvote 0
A module is just the container where your VBA code (procedures and functions) exist.
You have all three of these procedures in the same module, right?

You need to put this line at the VERY top of that module, before any other code:
Code: 
[COLOR=#333333]Public PDFExists As Boolean[/COLOR]
just like it shows in that link I sent you.
 
Upvote 0
Right click on sheet tab & view code.

I see the below.

Code: 
Option ExplicitPublic
PDFExists As Boolean
Private Sub SUMMARYTRANSFER()
    Dim rFndCell As Range
    Dim strData As String
    Dim stFnd As String
    Dim fRow As Long
    Dim sh As Worksheet
    Dim ws As Worksheet
    Dim strDate As String


    Set ws = Sheets("G INCOME")
    Set sh = Sheets("G SUMMARY")
    stFnd = ws.Range("G3").Value
    strDate = ws.Range("G5").Value
    With sh
        Set rFndCell = .Range("C5:C17").Find(stFnd, LookIn:=xlValues)
        If Not rFndCell Is Nothing Then
            fRow = rFndCell.Row
            If CDate(strDate) > CDate("05/04/2019") Then
                sh.Cells(fRow, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            Else:
                sh.Cells(fRow - 12, 4).Resize(, 2).Value = ws.Range("J31,K31").Value
            End If
            MsgBox "Transfer To Summary Sheet Also Completed", vbInformation + vbOKOnly, "INCOME TRANSFER SHEET MESSAGE"
        Else
            MsgBox "DOES NOT EXIST"
        End If
        Range("G5:H30").ClearContents
        Range("G5").Select
        ActiveWorkbook.Save
    End With
End Sub
Private Sub INCOMETRANSFER()
    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        PDFExists = True
        Exit Sub
    Else
        PDFExists = False
    End If
    Dim strFileName As String
    
        strFileName = "C:\Users\Ian\Desktop\GRASS CUTTING\CURRENT GRASS SHEETS\INCOME 2019-2020\" & _
        Range("J3") & "_" & Format(Month(DateValue(Range("G3") & " 1, " & "2019")), "00") & " " & Range("G3") & ".pdf"


    If Dir(strFileName) <> vbNullString Then
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS NOT SAVED AS IT ALREADY EXISTS", vbCritical + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"
        Exit Sub
    End If
    
    With ActiveSheet
        .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strFileName, Quality:=xlQualityStandard, IncludeDocProperties:=True
        MsgBox "INCOME GRASS SHEET " & Range("G3") & " " & Range("J3") & " WAS SAVED SUCCESSFULLY", vbInformation + vbOKOnly, "INCOME SUMMARY GRASS SHEET MESSAGE"


    End With


End Sub
Private Sub TransferButton_Click()
    
    Call INCOMETRANSFER
    
    If PDFExists Then
'       Do nothing
    Else
        Call SUMMARYTRANSFER
    End If
    
End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

I
  • Solved
Can you explain this CDate code please
2
Replies
13
Views
952
ipbr21054
I
I
  • Question Question
RTE 13 Type Mismatch message
Replies
1
Views
394
rollis13
rollis13
I
  • Solved
Advice to remove redundant line of code currently in use
2
Replies
10
Views
718
nemmi69
nemmi69
I
  • Question Question
Code only runs if on command button
Replies
1
Views
428
ipbr21054
I
I
  • Solved
Cell value must match criteria before save can continue
Replies
6
Views
436
ipbr21054
I

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top