Free Microsoft Excel 2013 Quick Reference

Select active slide by slide number in existing ppt through excel vba

Hi

I have already posted a query like this before but dint get a response...so im trying my luck again.

I have some worksheets in a workbook which contain some charts which I have to copy onto a powerpoint presentation. I have to copy one chart onto one slide and then the next chart from the next sheet onto the next slide and so on. Im using a macro which selects either the current slide as active slide (i.e. copies all the charts onto one slide) or appends the slides to the end of the presentation. This isnt what I want and i am trying to figure out if I can select the active slide in that presentation by slide number. Unfortunately I havent been able to do it.
Any ideas on this would be appreciated. Thanks.

P.S.: Here is the macro i am using

Sub Copy_Paste_to_PowerPoint2()

'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim ppApp As PowerPoint.Application
Dim ppSlide As PowerPoint.Slide

Dim SheetName As String
Dim TestRange As Range
Dim TestSheet As Worksheet
Dim TestChart As ChartObject

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean
Dim ChartNumber As Long

Dim PasteRange As Boolean
Dim RangePasteType As String
Dim RangeName As String
Dim AddSlidesToEnd As Boolean
Dim shts As Worksheet
'Parameters

'SheetName - name of sheet in Excel that contains the range or chart to copy

'PasteChart -If True then routine will copy and paste a chart
'PasteChartLink -If True then Routine will paste chart with Link; if = False then paste chart no link
'ChartNumber -Chart Object Number
'
'PasteRange - If True then Routine will copy and Paste a range
'RangePasteType - Paste as Picture linked or unlinked, "HTML" or "Picture". See routine below for exact values
'RangeName - Address or name of range to copy; "B3:G9" "MyRange"
'AddSlidesToEnd - If True then appednd slides to end of presentation and paste. If False then paste on current slide.

'use active sheet. This can be a direct sheet name



SheetName = Sheet2.Name

'Setting PasteRange to True means that Chart Option will not be used
PasteRange = True
RangeName = ("b2:g16") '"MyRange"
RangePasteType = "Picture"
rangelink = True

PasteChart = False
PasteChartLink = True
ChartNumber = 1

AddSlidesToEnd = False


'Error testing
On Error Resume Next
Set TestSheet = Sheets(SheetName)
Set TestRange = Sheets(SheetName).Range(RangeName)
Set TestChart = Sheets(SheetName).ChartObjects(ChartNumber)
On Error GoTo 0

If TestSheet Is Nothing Then
MsgBox "Sheet " & SheetName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If

If PasteRange And TestRange Is Nothing Then
MsgBox "Range " & RangeName & " does not exist. Macro will exit", vbCritical
Exit Sub
End If

If PasteRange = False And PasteChart And TestChart Is Nothing Then
MsgBox "Chart " & ChartNumber & " does not exist. Macro will exit", vbCritical
Exit Sub
End If


'Look for existing instance
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Create new instance if no instance exists
If ppApp Is Nothing Then Set ppApp = New PowerPoint.Application
'Add a presentation if none exists
If ppApp.Presentations.Count = 0 Then ppApp.Presentations.Add

'Make the instance visible
ppApp.Visible = True

'Check that a slide exits, if it doesn't add 1 slide. Else use the last slide for the paste operation
If ppApp.ActivePresentation.Slides.Count = 0 Then
Set ppSlide = ppApp.ActivePresentation.Slides.Add(1, ppLayoutBlank)
Else
If AddSlidesToEnd Then
'Appends slides to end of presentation and makes last slide active
ppApp.ActivePresentation.Slides.Add ppApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank
ppApp.ActiveWindow.View.GotoSlide ppApp.ActivePresentation.Slides.Count
Set ppSlide = ppApp.ActivePresentation.Slides(ppApp.ActivePresentation.Slides.Count)
Else
'Sets current slide to active slide
Set ppSlide = ppApp.ActiveWindow.View.Slide
End If
End If

'Options for Copy & Paste Ranges and Charts
If PasteRange = True Then
'Options for Copy & Paste Ranges
If RangePasteType = "Picture" Then
'Paste Range as Picture
Worksheets(SheetName).Range(RangeName).Copy
'ppSlide.Shapes.PasteSpecial(ppPasteDefault, link:=rangelink).Select
'ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, link:=rangelink).Select
'ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, , link:=rangelink).Select
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
Else
'Paste Range as HTML
Worksheets(SheetName).Range(RangeName).Copy
ppSlide.Shapes.PasteSpecial(ppPasteHTML, link:=rangelink).Select
End If
Else
'Options for Copy and Paste Charts
Worksheets(SheetName).Activate
ActiveSheet.ChartObjects(ChartNumber).Select
If PasteChartLink = True Then
'Copy & Paste Chart Linked
ActiveChart.ChartArea.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'Copy & Paste Chart Not Linked
ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
ppSlide.Shapes.Paste.Select
End If
End If

'Center pasted object in the slide
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True

AppActivate ("Microsoft PowerPoint")
Set ppSlide = Nothing
Set ppApp = Nothing

End Sub
PLEASE HELP.


Post your answer or comment

comments powered by Disqus
Currently, I am "reading" Power Programming and I am scheduled to attend the power excel macro class next week in Akron...

Would the cd's slide your way through excel: VBA be a good addition or is there a "better" way to speed up the process of learning VBA?

thanks
frank

I was looking to purchase "Slide your way through Excel VBA". Is there any option way I can download it rather than ordering for the physical CD?

I recently purchased the Excel VBA bundle. I finally got around to trying the Slide your way through excel VBA. I installed it and tried to run it. The problem is when I click To Proceed click here. The button responds but nothing happens. I have Office Professional 2003 and power point is installed. I even tried installing the power point viewer with the same results. The help button works but I cannot start a lesson. I very frustrated because when you purchase something, you expect it to work. Any suggestions on how to fix this? I uninstalled the excel VBA software and then reinstalled it, all with the same results.

I am trying to randomly select a repeating number in a matrix. I have seen the different random number and random select codes out there, but specifically what I'm asking is how to go about selecting a number that repeats in a matrix multiple times, not numbers between a certain range or a specific number that occurs in a matrix either. In other words, say I have a matrix like the following:
0 0 0 0 0 0 5 0 0 0 5 0 4 4 0 0 4 0 0 0 0 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 0 5 0 8 0 0 0 9 0 0 0 0 0 0 5 0 5 0 0 There are multiple 5's here, but for my purposes I only want to select one of those 5's. Is there a way to do this in Excel?

Also, I can only run macros in MSExcel 2004 for Mac because 2008 doesn't allow macros. Hopefully that doesn't cause any probs.

Thanks,
Sam

I have an Excel chart of two columns of numbers. One column has
angular values (from 1 degree to 45 degrees) that are to be spaced by
intervals specified by numbers in the second column (1.3 inches to
14.1 inches).

Is there a program that will place numbers specified in the first
column by the intervals spcified in the second column? For example,
say that the column of numbers we
deg inches
1 1.3
10 4.1
15 5.7
20 6.3

Is there a program that will place the 1 degree at 1.3 inches above a
reference point in a column, 10 degrees at 4.1 inches above a reference
point, 15 degrees 5.7 inches above a reference point and so on?

15 (---------------5.7 inches)

10 (----------------4.1 inches)

1 (-----------------1.3 inches)

---------------------------------------0 inches

I need to sort a column of alphanumic numbers in EXCEL with it ignoring the
prefix letters.

Hello!

I'm new here and not very good in english so I hope I will explain my problem well.

Generally, I need an array formula to sort table by numbers. Let's say I have numbers in cells (A1:A15) and text in cells (B1:B15), and need to sort table (A1:B15) by numbers in column (A1:A15) using dynamic array formula. I found a formula for sorting numbers only, but can't figure out how can I sort associated text also.. Array formula for sorting numbers would look like this:

(I choose cells C1:C15 and write folowing formula in formula bar)
=SMALL(A1:A15;ROW(INDIRECT("1:"&ROWS(A1:A15))))
(Then I press ctrl+shift+enter to add array formula)

I get sorted column (A1:A15) in cells (C1:C15), but I need to get column (B1:B15) in cells (D1:D15) also, sorted by numbers from (A1:A15)

I would be very gratefull if someone could help me to figure out how can I include text from (B1:B15) into that dynamic sorting array formula!

Best regards

Thanks everyone . . . I'd really appreciate if we can take a new look at this request. I have never found an answer.

I have a program that has all Excel Workbooks in seperate instances of Excel. There is a very sound reason for doing this.

The user has maybe 3 to 10 workbooks open. There are times when a workbook is active and has a Macro Link to open one of the already open workbooks.

When the user clicks the link, they naturally get an error message stating that the workbook is already open. Then they have to close the error msg and click on the Macrosoft Tab and look thru the list of open workbooks and then click the one they are looking for. Additionally, in this Menu Program the user really doesn't even have to know the name of the various workbooks.

I hope everyone will believe me when I state that this program works berautifully. Right now I am simply cleaning up and making a few little things work better.

QUESTION When the user clicks on a macro link that is to open a workbook that is already open, how - On error - can I have the macro continue on and activate the requested workbook - - - Please remember they are all in separate instances of Excel.

P.S. Since the code I'm using can determine if the requested workbook is already open, I think there has to be a way to activate that workbook.

This should be easy, but I'm stumped (relatively new user). I have a column
of sequential numbers (except that the last numbers are 0) and I want to
select the next highest number in that range.

Hello Guys and Dolls, I need some help

I have a column titled PA that has several cells with numbers, like 141, 151, 161, 242, 251, 382 etc. Is there a way that I can replace all these numbers in the column using a vba code.

For example, replacing all the numbers beginning with 1** to 1 and 2** to 2.

Thanks

Mini12

I would like to count the number of occurence of a user given number in a range through VBA code. Any help. Have attached a sample with this.

Hi Guys,

I am trying to update specific fields of table in Ms Access, through Excel VBA. My select and add new record queries work, but the update query always throws the RUN TIME ERROR 80040e10 - "No Value Given To One or More Required Parameters"

I have checked my table name and the other field names over and over again, but I see nothing wrong with the quesry. I am trying to update a few fields from the database, for a existing record number (autonumber).


	VB:
	
 
Function CheckDB(Serial_No_New_Part As String, Serial_No_Failed_Part As String, ConStr As String) _ 
    As Boolean 
    Dim MsgBox_Answer As Integer 
     
     ' Variable stores ADO Connection Object to Ms Access DB
    Dim cnt As New ADODB.Connection 
     
     ' Variable for Recordset Object
    Dim rst As New ADODB.Recordset 
     
     ' Variable stores Database path
    Dim strDB As String 
     
     
     ' Variable stores SQL 'SELECT' Query
    Dim SQLSelectNewPart As String 
    Dim SQLSelectFailedPart As String 
    Dim SQLUpdate As String 
     
    Dim Primary_No_Failed_Part As Long 
    Dim Run_Time_Hrs_Failed_Part As Long 
    Dim Part_Status_Failed_part As String 
    Dim Date_Failed_Failed_part As Date 
    Dim Failed_Location_Failed_Part As String 
    Dim Failure_History_Failed_Part As String 
    Dim Description_Failed_Part As String 
     
     ' Set the string to the path of your database
    strDB = ConStr 
     
     ' Open connection to the database
    cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
    "Data Source=" & strDB & ";" 
     
    rst.Open SQLSelectNewPart, cnt, adOpenDynamic, adLockBatchOptimistic, adCmdText 
     
     
     ' In simple words, look whether any records in the DB contain the same "Part_Serial_No"
     ' Check whether recordset is empty,implies no records found
     ' BOF = Begining of File
     ' EOF = End of File
     ' IF ((Not BOF = TRUE) AND (Not EOF = TRUE)), Implies Records Have Been Found
    If (rst.BOF = False And rst.EOF = False) Then 
         'Primary_Key = rst.Fields("Primary_No").Value
         
        MsgBox_Answer = MsgBox("A part with the matching 'Serial No' already exists in the Database" _ 
        & vbCrLf & "Click on the 'OK BUTTON' to display the 'ADD REPAIRED PART FORM'" & vbCrLf & _ 
        "or click on the 'CANCEL BUTTON' to edit the 'ADD NEW/REPLACE OLD FORM'", vbOKCancel, _ 
        "Existing Part in Database") 
         
        If (MsgBox_Answer = 1) Then 
             
             'Temporary Storage - Retrieve Existing Failed Tage Info from Database
             'Store this info temporarily on Sheet7 - Row(2-3), Column 5
            Sheet7.Cells(2, 5).Value = CLng(rst.Fields("Primary_No").Value) 
             'Failed Part Row No on Sheet1 retrieved from UserForm6
            Sheet7.Cells(3, 5).Value = CLng(UserForm6.TextBox17.Value) 
             'Write DB Path
            Sheet7.Cells(4, 5).Value = UCase(CStr(strDB)) 
             
             
             'Close Connection Objects and Recordset Objects.
             ' Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
             
             
            CheckDB = False 
             
            Unload UserForm6 
            UserForm1.Show 
             
        ElseIf (MsgBox_Answer = 2) Then 
            CheckDB = False 
             
             'Close Connection Objects and Recordset Objects.
             'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
            Exit Function 
        Else 
            CheckDB = False 
             
             'CloseConnection Objects and Recordset Objects.
             'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
            Exit Function 
        End If 
         
         'Else no records have been found - Implies New Part is New and is not a Failed part that has been repaired
         'Check whether Failed Part exists in DB
         'If Failed Part Exists, Append existing record
         'Else Add New Record for Failed Part in DB
    Else 
        rst.Close 
         'Now check whether Failed Part exists in DB
        SQLSelectFailedPart = "Select * FROM Failed Where Serial_No= '" _ 
        & UCase(CStr(Serial_No_Failed_Part)) & "'" 
         
         'Open recordset based on Trial table
        rst.Open SQLSelectFailedPart, cnt, adOpenDynamic, adLockBatchOptimistic, adCmdText 
         
        If (rst.BOF = True And rst.EOF = True) Then 
             
             'Add Failed Part Data as a new Record
             'Close Open Recordset
            rst.Close 
             
             '*********START Procedure to Add New Record********
            rst.Open "Failed", cnt, adOpenKeyset, adLockOptimistic, adCmdTable 
            rst.AddNew 
            rst!Part = UCase(CStr(UserForm6.TextBox14.Value)) 
            rst!Serial_No = UCase(CStr(UserForm6.ComboBox3.Value)) 
            rst!Material_Type = UCase(CStr(UserForm6.TextBox9.Value)) 
            rst!Run_Time_Hours = CLng(UserForm6.TextBox10.Value) 
            rst!Current_Part_Status = UCase(CStr(UserForm6.ComboBox4.Value)) 
            rst!Date_Failed = Format(CDate(UserForm6.TextBox12.Value), "mm/dd/yyyy") 
            rst!Failed_Location = UCase(CStr(UserForm6.TextBox15.Value)) 
            rst!Vendor_Name = UCase(CStr(UserForm6.TextBox13.Value)) 
             
            rst!Description = Replace(UCase(CStr(UserForm6.TextBox19.Value)), Chr(34), "''") 
            rst.Update 
             
            CheckDB = True 
             
             'close Connection Objects and Recordset Objects.
             'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
             
             
             'If existing record found, then Append and Update existing record
        Else 
            Primary_No_Failed_Part = rst.Fields("Primary_No").Value 
             
            Decription_Failed_Part = Replace(UCase(CStr(rst.Fields("Description").Value)), _ 
            Chr(34), "'") 
             
            Part_Status_Failed_part = UCase(CStr("Failed")) 
             
            Run_Time_Hrs_Failed_Part = CLng(rst.Fields("Run_Time_Hours")) 
             
            Date_Failed_Failed_part = Format(rst.Fields("Date_Failed"), "mm/dd/yyyy") 
             
            Failed_Location_Failed_Part = UCase(CStr(rst.Fields("Failed_Location"))) 
             
             'Close open RecordSet
            rst.Close 
             
            Failure_History_Failed_Part = UCase(CStr("Run Time Hours = " & Run_Time_Hrs_Failed_Part & _ 
            vbCrLf & "Date_Failed = " & Format(CDate(Date_Failed_Failed_part), "dd,mmm,yyyy") & _ 
            vbCrLf & "Failure_Location = " & Failed_Location_Failed_Part & vbCrLf & _ 
            "---------------------------------------" & vbCrLf)) 
             
            Description_Failed_Part = UCase(CStr(vbCrLf & "-----------------------------------" & vbCrLf & _ 
            UCase(CStr(UserForm6.TextBox19.Value)))) 
             
            Description_Failed_Part = Replace(Description_Failed_Part, Chr(34), "''") 
             
             
             'SQL UPDATE QUERY
            SQLUpdate = "UPDATE Failed SET [Run_Time_Hours] = " & CLng(UserForm6.TextBox10.Value) & _ 
            ", [Current_Part_Status] = '" & UCase(CStr(Part_Status_Failed_part)) & _ 
            "', [Date_Failed] = " & CDate(UserForm6.TextBox12.Value) _ 
            & ", [Failed_Location] = '" & UCase(CStr(UserForm6.TextBox15.Value)) & _ 
            "', [Failure_History] = '" & Failure_History_Failed_Part & _ 
            "', [Description] = '" & Description_Failed_Part & _ 
            "' WHERE Failure.Primary_No = " & CLng(Primary_No_Failed_Part) 
             
             
             'ERROR on this statement
            rst.Open SQLUpdate, cnt 
             
             
            CheckDB = True 
             
             'close Connection Objects and Recordset Objects.
             'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
             
            Unload UserForm6 
        End If 
         
    End If 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
--------------------------------------------------------------------------

Could someone point our what I am doing wrong. The error occurs on the statement

	VB:
	
rst.Open SQLUpdate, cnt 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
,
RUN TIME ERROR: 80040e10 - "No Value Given To One or More Required Parameters"

Thanks.

Regards,

Cnerurkar

Hello everyone,

at the moment I am trying to import data from a table in internet explorer into excel. However, the table length is variable so I want to count the number of rows in the HTML table so that I can use it in a for loop to excel. At the moment I am using the following code:


	VB:
	
rowcount = ieTbl.Columns(1).Cells.Length - 1 
For n = 0 To rowcount 
    For j = 0 To ieTbl.Rows(1).Cells.Length - 1 
        Sheet1.Cells(n, j + 1).Value = ieTbl.Rows(n).Cells(j).innertext 
    Next j 
Next n 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
I get an error that the object does't support the property or method on line:


	VB:
	
rowcount = ieTbl.Columns(1).Cells.Length - 1 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Does anyone know how to do a proper rowcount for html tables in vba?

I think this is an E-mail issue or opening files with the same name but can someone explain why sometimes there are numbers in brackets after an Excel file name?

Test file.xls becomes Test file [2].xls sometimes.

Is there a way to stop this from happening?

Thanks.....

When I key in beyong 15 digits number in a cell of Excel 2000 or office XP
Excel eats up 16th digit and places a 0 and go-on like that.

Please help me

Hi Guys,

I am trying to update specific fields of table in Ms Access, through Excel VBA. My select and add new record queries work, but the update query always throws the RUN TIME ERROR 80040e10 - "No Value Given To One or More Required Parameters"

I have checked my table name and the other field names over and over again, but I see nothing wrong with the quesry. I am trying to update a few fields from the database, for a existing record number (autonumber).

Function CheckDB(Serial_No_New_Part As String, Serial_No_Failed_Part As String, ConStr As
String) _ 
    As Boolean 
    Dim MsgBox_Answer As Integer 
     
    ' Variable stores ADO Connection Object to Ms Access DB
    Dim cnt As New ADODB.Connection 
     
    ' Variable for Recordset Object
    Dim rst As New ADODB.Recordset 
     
    ' Variable stores Database path
    Dim strDB As String 
     
     
    ' Variable stores SQL 'SELECT' Query
    Dim SQLSelectNewPart As String 
    Dim SQLSelectFailedPart As String 
    Dim SQLUpdate As String 
     
    Dim Primary_No_Failed_Part As Long 
    Dim Run_Time_Hrs_Failed_Part As Long 
    Dim Part_Status_Failed_part As String 
    Dim Date_Failed_Failed_part As Date 
    Dim Failed_Location_Failed_Part As String 
    Dim Failure_History_Failed_Part As String 
    Dim Description_Failed_Part As String 
     
    ' Set the string to the path of your database
    strDB = ConStr 
     
    ' Open connection to the database
    cnt.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _ 
    "Data Source=" & strDB & ";" 
     
    rst.Open SQLSelectNewPart, cnt, adOpenDynamic, adLockBatchOptimistic, adCmdText 
     
     
    ' In simple words, look whether any records in the DB contain the same "Part_Serial_No"
    ' Check whether recordset is empty,implies no records found
    ' BOF = Begining of File
    ' EOF = End of File
    ' IF ((Not BOF = TRUE) AND (Not EOF = TRUE)), Implies Records Have Been Found
    If (rst.BOF = False And rst.EOF = False) Then 
         'Primary_Key = rst.Fields("Primary_No").Value
         
        MsgBox_Answer = MsgBox("A part with the matching 'Serial No' already exists in the Database" _ 
        & vbCrLf & "Click on the 'OK BUTTON' to display the 'ADD REPAIRED PART FORM'" & vbCrLf & _

        "or click on the 'CANCEL BUTTON' to edit the 'ADD NEW/REPLACE OLD FORM'", vbOKCancel, _ 
        "Existing Part in Database") 
         
        If (MsgBox_Answer = 1) Then 
             
            'Temporary Storage - Retrieve Existing Failed Tage Info from Database
            'Store this info temporarily on Sheet7 - Row(2-3), Column 5
            Sheet7.Cells(2, 5).Value = CLng(rst.Fields("Primary_No").Value) 
            
            'Failed Part Row No on Sheet1 retrieved from UserForm6
            Sheet7.Cells(3, 5).Value = CLng(UserForm6.TextBox17.Value) 
            
            'Write DB Path
            Sheet7.Cells(4, 5).Value = UCase(CStr(strDB)) 
             
             
            'Close Connection Objects and Recordset Objects.
            ' Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
             
             
            CheckDB = False 
             
            Unload UserForm6 
            UserForm1.Show 
             
        ElseIf (MsgBox_Answer = 2) Then 
            CheckDB = False 
             
            'Close Connection Objects and Recordset Objects.
            'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
            Exit Function 
        Else 
            CheckDB = False 
             
            'CloseConnection Objects and Recordset Objects.
            'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
            Exit Function 
        End If 
         
    'Else no records have been found - Implies New Part is New and is not a Failed part that has been repaired
    'Check whether Failed Part exists in DB
    'If Failed Part Exists, Append existing record
    'Else Add New Record for Failed Part in DB
    Else 
        rst.Close 
        'Now check whether Failed Part exists in DB
        SQLSelectFailedPart = "Select * FROM Failed Where Serial_No= '" _ 
        & UCase(CStr(Serial_No_Failed_Part)) & "'" 
         
        'Open recordset based on Trial table
        rst.Open SQLSelectFailedPart, cnt, adOpenDynamic, adLockBatchOptimistic, adCmdText 
         
        If (rst.BOF = True And rst.EOF = True) Then 
             
            'Add Failed Part Data as a new Record
            'Close Open Recordset
            rst.Close 
             
            '*********START Procedure to Add New Record********
            rst.Open "Failed", cnt, adOpenKeyset, adLockOptimistic, adCmdTable 
            rst.AddNew 
            rst!Part = UCase(CStr(UserForm6.TextBox14.Value)) 
            rst!Serial_No = UCase(CStr(UserForm6.ComboBox3.Value)) 
            rst!Material_Type = UCase(CStr(UserForm6.TextBox9.Value)) 
            rst!Run_Time_Hours = CLng(UserForm6.TextBox10.Value) 
            rst!Current_Part_Status = UCase(CStr(UserForm6.ComboBox4.Value)) 
            rst!Date_Failed = Format(CDate(UserForm6.TextBox12.Value), "mm/dd/yyyy") 
            rst!Failed_Location = UCase(CStr(UserForm6.TextBox15.Value)) 
            rst!Vendor_Name = UCase(CStr(UserForm6.TextBox13.Value)) 
             
            rst!Description = Replace(UCase(CStr(UserForm6.TextBox19.Value)), Chr(34), "''") 
            rst.Update 
             
            CheckDB = True 
             
            'close Connection Objects and Recordset Objects.
            'Close ADO objects
            rst.Close 
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
             
             
        'If existing record found, then Append and Update existing record
        Else 
            Primary_No_Failed_Part = rst.Fields("Primary_No").Value 
             
            Decription_Failed_Part = Replace(UCase(CStr(rst.Fields("Description").Value)), _ 
            Chr(34), "'") 
             
            Part_Status_Failed_part = UCase(CStr("Failed")) 
             
            Run_Time_Hrs_Failed_Part = CLng(rst.Fields("Run_Time_Hours")) 
             
            Date_Failed_Failed_part = Format(rst.Fields("Date_Failed"), "mm/dd/yyyy") 
             
            Failed_Location_Failed_Part = UCase(CStr(rst.Fields("Failed_Location"))) 
             
            'Close open RecordSet
            rst.Close 
             
            Failure_History_Failed_Part = UCase(CStr("Run Time Hours = " & Run_Time_Hrs_Failed_Part & _ 
            vbCrLf & "Date_Failed = " & Format(CDate(Date_Failed_Failed_part), "dd,mmm,yyyy")
& _ 
            vbCrLf & "Failure_Location = " & Failed_Location_Failed_Part & vbCrLf & _ 
            "---------------------------------------" & vbCrLf)) 
             
            Description_Failed_Part = UCase(CStr(vbCrLf & "-----------------------------------" & vbCrLf
& _ 
            UCase(CStr(UserForm6.TextBox19.Value)))) 
             
            Description_Failed_Part = Replace(Description_Failed_Part, Chr(34), "''") 
             
             
            'SQL UPDATE QUERY
            SQLUpdate = "UPDATE Failed SET [Run_Time_Hours] = " & CLng(UserForm6.TextBox10.Value) & _ 
            ", [Current_Part_Status] = '" & UCase(CStr(Part_Status_Failed_part)) & _ 
            "', [Date_Failed] = " & CDate(UserForm6.TextBox12.Value) _ 
            & ", [Failed_Location] = '" & UCase(CStr(UserForm6.TextBox15.Value)) & _ 
            "', [Failure_History] = '" & Failure_History_Failed_Part & _ 
            "', [Description] = '" & Description_Failed_Part & _ 
            "' WHERE Failure.Primary_No = " & CLng(Primary_No_Failed_Part) 
             
             
            'ERROR on this statement
            cnt.open SQLUpdate             
             
            CheckDB = True 
             
            'close Connection Objects and Recordset Objects.
            'Close ADO objects
            cnt.Close 
            Set rst = Nothing 
            Set cnt = Nothing 
             
            Unload UserForm6 
        End If 
         
    End If 
End Function
Could someone point our what I am doing wrong. The error occurs on the statement
VBA:
cnt.open SQLUpdate

ERROR: RUN TIME ERROR: 80040e10 - "No Value Given To One or More Required Parameters"

Thanks.

Regards,

Cnerurkar

I have a bunch of numbers in cells A1 through E60. I want to know if any of them is anywhere in the range G1 through P200. None of the numbers in either range is in any order but they are all numeric. I'd like to use conditional formatting to highlight a number in the first range if it is in the second. This doesn't seem like it should be that hard but I'm stuck. Any help would be appreciated.

(Excell 2007)

MacPadana

Hi,

To Auto fill the serial number in "B" column using excel macro.

Input Data:
A 1 2 2 2 3 3 4 4 4

Output like as:

A B 1 1 2 1 2 2 2 3 3 1 3 2 4 1 4 2 4 3

Thanks in advance

LJ

By executing the code in excel VBA I get an error at the following step.

Dim objWord as Word.Application

The same happend when I try to load Excel through VB .i.e. the error occurs here

Dim objexl as Excel.Application

also when I tried to load Word through VB i.e. the error message is shown at

Dim objWord as Word.Application

What is the reason for this. Any one can help me out in resolving this issue

Hari

Hey everybody

Is there a way to check if a folder in outlook excist if not then create the folder from code in Excel VBA?

here is my code

[Dim ns As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim MailItem As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String
Dim i As Integer
On Error Resume Next
'connections
Set Inbox = GetNamespace("MAPI").Folders("postkasse - npb.pp").Folders("Inbox")
Set Igangværende = GetNamespace("MAPI").Folders("postkasse - npb.pp").Folders("Igangværende sager")
SaveFolder = "Q:KunderapporteringPPRapporteringSlutrapportering"
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "Der er ingen opsigelser i npb.postkassen!", vbInformation, _
"Nothing Found"
Exit Sub
End If
'Cheking for Close-Costumer-Atmtachments, if any save atmtachments found, move mail to right folder
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Left(Atmt.FileName, 17) = "lukning af kunde " Then
Closedate = Mid(Atmt.FileName, Len(Atmt.FileName) - 13, 10)
'here should it check if the folder excist if not add the folder ("Udgår " & Closedate)
Set mydestfolder = Igangværende.Folders("Udgår " & Closedate)
Atmt.SaveAsFile SaveFolder & Atmt.FileName
Item.Move mydestfolder
End If
Next
Next]

I am attempting to move an Excel formula from a worksheet and place it
in an Excel VBA function.

Naively, I thought that I could simply take the worksheet equation,
pass it variables, and add "Application." to all worksheet
function. I took the "Application." out of the VBA function to make it
easier to read.

Unfortunately this does not work for the OFFSET function, but I have
not been able to figure out just why.

Excel Worksheet Function:
=SUMPRODUCT(OFFSET(CI9,-MIN(CF9-Year_First,Fac_Depr),0,MIN(CF9-Year_First+1,Fac_Depr+1),1),
OFFSET(FirstInvFacTangDrillDepr,-MIN(CF9-Year_First,Fac_Depr),0,MIN(CF9-Year_First+1,Fac_Depr+1),1))

CF9,CI9 and named cells are single cells as opposed to multiple ones
such as in a range

Attempted Excel VBA Function:
Function FirstYearDepreciation(Current_Year, Year_First, Fac_Depr,
FirstInvFacTangDrillDepr, Eligible_Depr)
Dim Current_Year As Double
Dim Year_First As Double
Dim Fac_Depr As Integer
Dim FirstInvFacTangDrillDepr As Double
Dim Eligible_Depr As Variant

FirstYearDepreciation = SumProduct( _
Offset(Eligible_Depr, -Min(Current_Year - Year_First, Fac_Depr), 0,
Min(Current_Year - Year_First + 1, Fac_Depr + 1), 1), _
Offset(FirstInvFacTangDrillDepr, -Min(Current_Year - Year_First,
Fac_Depr), 0, Min(Current_Year - Year_First + 1, Fac_Depr + 1), 1))

End Function

Can anyone shed some light on this?

Thanks in advance.

Floyd

Hi All

I got a code from another website, and modified as needed:

Public Sub EmailCode()

Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
MailDBName = Left$(UserName, 1) & Right$(UserName, (Len(UserName) - InStr(1, UserName, " ")))
Set Maildb = Session.GETDATABASE("", MailDBName)
If Maildb.IsOpen <> True Then
    On Error Resume Next
    Maildb.OPENMAIL
End If

Set MailDoc = Maildb.CreateDocument
MailDoc.form = "Memo"

With MailDoc
    .Sendto = "a@a.com"
    .Copyto = ""
    .blindcopyto = ""
    .Subject = "This is a test of emailing in Lotus through Excel VBA"
    .Body = "Success!"
End With

MailDoc.SaveMessageOnSend = True

MailDoc.posteddate = Now()

MailDoc.Send 0, "a@a.com"

End Sub
It works great except it is emailing from my personal email mailbox, and I'd like to email from a shared mailbox. Anyone know what I would change to do that? I think it is one of the two lines I bolded above.

Thanks!

Hi,

I am continuing someone else's work and I am finding that a piece of code that is supposed to create a windows shortcut of a file in a certain folder produces a run-time error -2147024893(80070003) (Method 'Save' of object 'IWshShortCut' failed)

the sub that produces the error is the following

Sub
ShortcutGen(strShortcutPath As String, strShortcutName As String, strShortcutToFile As String)
    ' Requires a reference to the Windows Scripting Host Object (WSHOM.OCX)
    Dim objWSH As IWshRuntimeLibrary.WshShell
    Dim objShortCut As IWshRuntimeLibrary.WshShortcut
    Dim strPath As String
    
    
    Set objWSH = New IWshRuntimeLibrary.WshShell
    Set objShortCut = objWSH.CreateShortcut(strShortcutPath & strShortcutName)
    
    objShortCut.TargetPath = strShortcutToFile
    objShortCut.Save
    
    Set objShortCut = Nothing
    Set objWSH = Nothing
    
End Sub
any idea of what might be going wrong or what should I check?
thanks!

I have some code that copies graphs from a workbook to a Powerpoint template. Works fine, most of the time, but I want to add an end page (End Page.ppt) to the presentation, and I'm struggling

Here's the current code:-

Private Sub CommandButton2_Click()

    Dim PPApp As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPSlide As PowerPoint.Slide
    Dim PPTTemp As Object
    
    
    Set PPTTemp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then PowerpointWasNotRunning = True
    Err.Clear
    
'       DetectExcel
    
    Set PPTTemp = GetObject("C:DataReport Template PF.ppt")
    
    PPTTemp.Application.Visible = True
    
    If ExcelWasNotRunning = True Then
        PPTTemp.Application.Quit
    End If
    
    ' Reference instance of PowerPoint
    On Error Resume Next
    
    ' Check whether PowerPoint is running
    Set PPApp = GetObject(, "PowerPoint.Application")
    If PPApp Is Nothing Then
        ' PowerPoint is not running, create new instance
        Set PPApp = CreateObject("PowerPoint.Application")
        PPApp.Visible = True
    End If
    On Error GoTo 0

    ' Reference presentation and slide
    On Error Resume Next
    If PPApp.Windows.Count > 0 Then
        ' There is at least one presentation
        ' Use existing presentation
        Set PPPres = PPApp.ActivePresentation
        ' Use active slide
        Set PPSlide = PPPres.Slides _
            (PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
    Else
        ' There are no presentations
        ' Create new presentation
        Set PPPres = PPApp.Presentations.Add
        ' Add first slide
        'Set PPSlide = PPPres.Slides.Add(1, ppLayoutBlank)
    End If
    On Error GoTo 0

    ' Some PowerPoint actions work best in normal slide view
    PPApp.ActiveWindow.ViewType = ppViewSlide
    
     'Add a new slide and paste in the chart
    SlideCount = PPPres.Slides.Count
    Set PPSlide = PPPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
    PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex

    Worksheets("Graph").Range("B24:M61").CopyPicture _
    Appearance:=xlScreen, Format:=xlPicture
    
    ' Paste chart
    PPSlide.Shapes.Paste.Select

    ' Align pasted chart
    PPApp.ActiveWindow.Selection.ShapeRange.Left = 75
    PPApp.ActiveWindow.Selection.ShapeRange.Top = 60
    
    PPApp.ActiveWindow.Selection.ShapeRange.Width = 525
    
    PPSlide.Shapes.Placeholders(1).TextFrame.TextRange.Text = Worksheets("Graph").Range("B23")
    PPSlide.Shapes.Placeholders(1).TextFrame.TextRange.Font.Size = 28
    PPSlide.Shapes.Placeholders(1).TextFrame.TextRange.Font.Bold = msoTrue
    PPSlide.Shapes.Placeholders(1).Left = 31
    PPSlide.Shapes.Placeholders(1).Top = 18
    PPSlide.Shapes.Placeholders(1).Width = 613.3
    PPSlide.Shapes.Placeholders(1).Height = 42.3
    
    ' Clean up
    Set PPSlide = Nothing
    Set PPPres = Nothing
    Set PPApp = Nothing

End Sub
Any help greatly appreciated.


No luck finding an answer? You could always try Google.