Forum - VBA Application-defined or object-defined error

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Application-defined or object-defined error (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/2083-application-defined-object-defined-error.html)

Application-defined or object-defined error

Καλησπέρα,

Χρησιμοποιώ την ακόλουθη συνάρτηση και όλα πηγαίνουν άριστα μέχρι την στιγμή που ζητώ στο Excel να κλείσει ως εφαρμογή.
Το μήνυμα λάθους που μου δείχνει είναι “Application-defined or object-defined error”.

Που είναι το λάθος;

Ευχαριστώ εκ των προτέρων για την βοήθεια σας.

Κώδικας:

Sub ImportDataSpore()

            

' **** Spore Invoice *****

           

'***Import data from other spreadsheet
 

        Application.ScreenUpdating = False
 

'***Import Data to Invoice

        Workbooks("Delivery.xlsx").Activate

        Worksheets("ExcelDeliveryQry").Range("A3", "E500").Select

        Selection.Copy

        Workbooks("INVOICE Spore.xls").Worksheets("PROVISIONS").Activate

        Range("A10").Select

        Workbooks("INVOICE Spore.xls").Worksheets("PROVISIONS").Paste

        Application.CutCopyMode = False

        Windows("INVOICE Spore.xls").Activate

        Range("B10").Select

        Workbooks("Delivery.xlsx").Close True

  

  

  Columns("B:B").ColumnWidth = 49.6

  

       

 '***Total (Qty * U/Price)

    

    Dim FirstRow As Long, FinalRow As Long, CalcRows As Long

    FirstRow = ActiveCell.Row

    FinalRow = Cells(Rows.Count, 2).End(xlUp).Row

    CalcRows = FinalRow - FirstRow + 1

    

  With Range("G10" & ":G" & FinalRow)

        .FormulaR1C1 = "=IF(RC[-2]<>"""",RC[-3]*RC[-2],"""")"

    End With
 

  

  '***Sum Net Amount

  

        Range("G10").Select

        LastRow = Cells(Rows.Count, "G").End(xlUp).Row

        Range("G" & LastRow + 1).Formula = "=sum(G10:G" & LastRow & ")"

    

     Range("G" & LastRow).Select

     With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .Weight = xlThin

    End With

    

   '***Bold Insert Net Amount

    

    Dim LR As Long

    

    LR = Cells(Rows.Count, "G").End(xlUp).Row

    

    Cells(LR, "B").Select

    ActiveCell.FormulaR1C1 = "Total Net Amount"

    Selection.Font.Bold = True

    Selection.Font.Italic = True

    Cells(LR, "G").Select

    Selection.Font.Bold = True

    Selection.Font.Italic = True

    

    

    '***Autofit

    Columns("E:G").Select

    Columns("E:G").EntireColumn.AutoFit

    

    '***Left Aligment

        Range("B9", Range("B9").End(xlDown)).Select

        With Selection

        .Font.Name = "Calibri"

        .Font.Size = 11

        .HorizontalAlignment = xlLeft

        .VerticalAlignment = xlTop

        .WrapText = True

        End With

    

    Range("G10", Range("G10").End(xlDown)).Select

        With Selection

        .Font.Name = "Calibri"

        .Font.Size = 11

        .VerticalAlignment = xlTop

        End With

        

    '***SGD Format

        

        Range("E10", Range("G10").End(xlDown)).Select

        Selection.NumberFormat = _

        "_([$SGD] * #,##0.00_);_([$SGD] * (#,##0.00);_([$SGD] * ""-""??_);_(@_)"

   

       

    '***Remove Links

    

    ActiveWorkbook.BreakLink Name:= _

        "D:\Documents\AAA PDF Files\Delivery.xlsx", Type:=xlExcelLinks

    With Selection

        .VerticalAlignment = xlTop

        .Orientation = 0

        .ReadingOrder = xlContext

    End With

    

    

    ' *****  Set Print Area  *******
 

Dim lastCell As Range

Set lastCell = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0)

Do Until Application.Count(lastCell.EntireRow) <> 0

Set lastCell = lastCell.Offset(-1, 0)

Loop

ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), lastCell).Address
 

    

'**** Bold Italic Keywords

    Application.Run "PERSONAL.XLSB!Bold_Italic_Keywords.Bold_Italic_Keywords"

    

    ' ****** SaveAs

    Workbooks("Invoice Spore.xls").Activate

    Range("B9").Select

    ActiveSheet.Copy

    ActiveWorkbook.SaveAs Filename:="D:\Documents\AAA PDF Files" _

    & "\" & ActiveCell.Value & ".xlsx", FileFormat:=51

    'FileFormat:=xlWorkbookNormal

      

    Application.ScreenUpdating = True

      
  ****** Close & Delete Delivery.xlsx

    On Error Resume Next

    Kill "D:\Documents\AAA PDF Files\Delivery.xlsx"

    ActiveWorkbook.Close SaveChanges:=False

    ActiveWorkbook.Close SaveChanges:=False

    On Error GoTo 0

    Application.Quit

    

End Sub

Καλησπέρα Θανάση!

Δεν σε αντιληφθήκαμε και σε προσπεράσαμε:blush:

Είδα τον κώδικα σου και έχω να κάνω τις εξής παρατηρήσεις.

Χρησιμοποιείς συνεχώς Activate και Select. Δεν υπάρχει λόγος.
Δε χρειάζεται να κάνεις αναπαράσταση των κινήσεων που θα έκανες χειροκίνητα μέσα από τη VBA.
Σε πολλές περιπτώσεις δεν χρειάζεται καν να κάνεις Copy Paste προγραμματιστικά.

Για παράδειγμα: η γραμμή Range("A1:A100").Value = Range("B1:B100").Value αντιγράφει τις τιμές
από την περιοχή "B1:B100" στην περιοχή "Α1:Α100" χωρίς να χρειαστούν Select , Activate , Copy και Paste.

Δεν διαπίστωσα κάποια συντακτικά λάθη.
Η μόνη μου υποψία σε σχέση με το πρόβλημα βρίσκεται στη γραμμή Application.Run "PERSONAL.XLSB!Bold_Italic_Keywords.Bold_Italic_Ke ywords"

Ωστόσο αφού μελέτησα τη ροή του κώδικα σου σου προτείνω να μελετήσεις τις τεχνικές που εφαρμόζονται στον παρακάτω (ενδεικτικό) κώδικα:

Κώδικας:

Option Explicit
 

Sub ImportDataSpore()

    Dim rngTarget As Range, wbDelivery As Workbook, wbInvoice As Workbook, wb As Workbook

    Dim wbDeliveryPath As String, aLinks As Variant, i As Integer
 

    Set wbDelivery = Workbooks("Delivery.xlsx")

    wbDeliveryPath = wbDelivery.FullName

    Set wbInvoice = Workbooks("INVOICE Spore.xls")

    Set rngTarget = wbInvoice.Worksheets("PROVISIONS").Range("A10:E507")
 

    Application.ScreenUpdating = False
 

    rngTarget.Value = wbDelivery.Worksheets("ExcelDeliveryQry").Range("A3:E500").Value '***Import Data to Invoice
 

    wbDelivery.Close True '***Close Workbook 'Delivery.xlsx'
 

    On Error Resume Next

    Kill wbDeliveryPath '***Delete Workbook 'Delivery.xlsx'
 

    On Error GoTo 0

    Set rngTarget = rngTarget.Resize(rngTarget.Rows.Count + 1, rngTarget.Columns.Count)
 

    With rngTarget

        .Font.Name = "Calibri"

        .Font.Size = 11

        .VerticalAlignment = xlTop
 

        With .Columns(2)

            .ColumnWidth = 49.6 '***Autofit

            .HorizontalAlignment = xlLeft

            .WrapText = True

        End With
 

        With .Columns(7)

            .FormulaR1C1 = "=IF(RC[-2]<>"""",RC[-3]*RC[-2],"""")" '***Total (Qty * U/Price)

            .Value = .Columns(7).Value

        End With
 

        With .Parent.Range("G508")

            .Value = Application.Sum(.Columns(7))

            .Borders(xlEdgeBottom).LineStyle = xlContinuous

            .Borders.Weight = xlThin

            .Font.Bold = True

            .Font.Italic = True

        End With

        

        '***SGD Format

        .Parent.Range("E10:G508").NumberFormat = "_([$SGD] * #,##0.00_);_([$SGD] * (#,##0.00);_([$SGD] * ""-""??_);_(@_)"

        .Parent.Columns("E:G").EntireColumn.AutoFit
 

        With .Parent.Range("B508")

            .Value = "Total Net Amount"

            .Font.Bold = True

            .Font.Italic = True

        End With

    End With

    

    '***Remove Links (Not needed since all formulas are converted to values)

'    aLinks = wbInvoice.LinkSources(xlExcelLinks)

'    If Not IsEmpty(aLinks) Then

'        For i = 1 To UBound(aLinks)

'            wbInvoice.BreakLink aLinks(i), xlLinkTypeExcelLinks

'        Next

'    End If
 

    With wbInvoice.Worksheets("PROVISIONS")

        .Activate    ' Δεν ξέρω αν η επόμενη γραμμή προϋποθέτει την ενεργοποίηση του φύλλου

        '**** Bold Italic Keywords

        Application.Run "PERSONAL.XLSB!Bold_Italic_Keywords.Bold_Italic_Keywords"

        .Activate    ' Δεν ξέρω αν η προηγούμενη γραμμή απενεργοποιεί το φύλλο

        

        ' *****  Set Print Area

        .PageSetup.PrintArea = Range("A1:G" & Evaluate("=MAX((2:600<>"""")*ROW(2:600))")).Address

        .Copy

    End With

    
     ' ***** SaveAs...

    ActiveWorkbook.SaveAs Filename:="D:\Documents\AAA PDF Files" _

                                    & "\" & Range("B9").Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook

                                    

    ' ***** Quit Application

    For Each wb In Application.Workbooks

        wb.Saved = True

    Next

    Application.Quit

End Sub

Καλή συνέχεια!

Τάσος

Τάσο καλησπέρα,

Σε ευχαριστώ για τις εύστοχες παρατηρήσεις σου.

Το πρόβλημα όμως παραμένει όταν πάω να κλείσω με την εντολή «Application.Quit» μου βγάζει το μήνυμα λάθους “Application-defined or object-defined error” σε ξεχωριστό παράθυρο αφού έχουν κλείσει πρώτα όλα τα φύλλα εργασίας

Δεν έχω την δυνατότητα να δω εάν μαρκάρετε κάποια γραμμή (highlight), ποια είναι η γραμμή που δημιουργεί το πρόβλημα.

Προσπάθησα με F5 (step by step) και όλα κυλούν κανονικά χωρίς πρόβλημα. Μέτα το κλείσιμο των φύλλων εργασίας και με την εντολή «Application.Quit» δημιουργείτε αυτό το σφάλμα.

Εάν αφαιρέσω την εντολή «Application.Quit», δεν υπάρχει πρόβλημα αλλά δεν κλείνει το Excel apps, πρέπει να το κλείσω χειροκίνητα.

Θανάσης

Θανάση,
Κάθισα, αφιέρωσα χρόνο για να σου προτείνω έναν κώδικα για να τον μελετήσεις (ενδεικτικός κώδικας) και εσύ αλλά και οι υπόλοιποι φίλοι στο φόρουμ.
Δεν είμαι σίγουρος ότι μπορεί να τρέξει αφού τον έγραψα "στα τυφλά" χωρίς δοκιμή και μη γνωρίζοντας το περιβάλλον του υπολογιστή σου και τις απαιτήσεις της εφαρμογής σου.

Πίστεψε με, αξίζει τον κόπο να δεις και να μελετήσεις ξανά τον κώδικα που σου πρότεινα.

Μήπως ο κώδικας σου κλείνει και το βιβλίο όπου περιέχεται επομένως δεν μπορεί να τρέξει η τελευταία γραμμή αφού έχει κλείσει και το έργο VBA του βιβλίου;
Αν προσέξεις στον κώδικα μου δεν κλείνω κάποια βιβλία. Απλά χρησιμοποιώ την έκφραση Application.Quit

Αν δεν ισχύει το παραπάνω τότε κάτι δεν πάει καλά με το PERSONAL.XLSB σε συνδυασμό με τον κώδικα σου.
Μπορείς να μας δείξεις τον κώδικα της μακροεντολής Bold_Italic_Keywords απο το PERSONAL.XLSB;

Επιπλέον δοκίμασε σε ένα νέο βιβλίο με απενεργοποιημένο το PERSONAL.XLSB το παρακάτω:

Κώδικας:

Sub test

   Dim wb As WorkBook

   For Each wb In Application.Workbooks

        wb.Saved = True

    Next

    Application.Quit

End sub

Πάτησε F1 με επιλεγμένη στη λέξη Quit στον VBE και διάβασε τη σχετική βοήθεια.

Περιμένουμε νέα σου.

Τάσος

Τάσο καλημέρα,

Τις παρατηρήσεις σου που μου έστειλες δεν τις χρησιμοποίησα ακόμη λόγω χρόνου.
Ελπίζω μέσα στο Σαββατοκύριακο να τις δω και να ασχοληθώ όπως μου προτείνεις.

Ως προς το κωδικό που μου ζητάς είναι o ακόλουθος.
Θα επανέλθω με τα υπόλοιπα.

Ευχαριστώ
Θανάσης

Κώδικας:



Sub Bold_Italic_Keywords()

Dim vntWords As Variant

Dim lngIndex As Long

Dim rngFind As Range

Dim strFirstAddress As String

Dim lngPos As Long
 

vntWords = Array("MAKER", "NON-RETURNABLE", "OFFER:", "DELIVERY TIME:", "EX STOCK", "NOT AVAILABLE", "EX WORK")

With ActiveSheet.UsedRange

    For lngIndex = LBound(vntWords) To UBound(vntWords)

        Set rngFind = .Find(vntWords(lngIndex), LookIn:=xlValues, LookAt:=xlPart)

        If Not rngFind Is Nothing Then

            strFirstAddress = rngFind.Address

            Do

                lngPos = 0

                Do

                    lngPos = InStr(lngPos + 1, rngFind.Value, vntWords(lngIndex), vbTextCompare)

                    If lngPos > 0 Then

                        With rngFind.Characters(lngPos, Len(vntWords(lngIndex)))

                            .Font.Bold = True

                            .Font.Italic = True

                            '.Font.Size = .Font.Size + 2

                            '.Font.ColorIndex = 3

                        End With

                    End If

                Loop While lngPos > 0

                Set rngFind = .FindNext(rngFind)

            Loop While rngFind.Address <> strFirstAddress

        End If

    Next

End With

End Sub

Τάσο καλημέρα,

Και χωρίς να απενεργοποιήσω το “PERSONAL.XLSB” χρησιμοποιώντας ένα νέο module με την μακρό-εντολή «test» το πρόγραμμα κλείνει κανονικά.
Δεν μπορώ να καταλάβω πού είναι το λάθος μου.

Κώδικας:

Sub test

   Dim wb As WorkBook

   For Each wb In Application.Workbooks

        wb.Saved = True

    Next

    Application.Quit

End sub

Δοκίμασα αλλά όχι πολύ επισταμένα τον κώδικα που μου έστειλες αλλά χρειάζεται αρκετό ψάξιμο. Πάντως και με αυτό τον κώδικα το πρόγραμμα του Excel δεν κλείνει και δίνει σφάλμα.

Ευχαριστώ
Θανάσης

Καλημέρα Θανάση!

Βάλε όλα τα βιβλία που σχετίζονται με το πρόβλημα ( και το PERSONAL.XLSB ) σε ένα zip και επισύναψε τα στο φόρουμ για να μπορέσουμε να αναπαραστήσουμε το πρόβλημα και να σου δώσουμε μια λύση.

Τάσος

Τάσο σε ευχαριστώ για την απεριόριστη συμπαράσταση και βοήθεια.
Δεν έχω λόγια να σ’ ευχαριστήσω.

Θανάσης

Καλησπέρα!

Θανάση... από ότι είδα θέλεις να περνάς δεδομένα από το Delivery.xlsx στο INVOICE Spore.xls,
μορφοποιείς τμήματα των κελιών με την συνάρτηση Bold_Italic_Keywords() (που λείπει από το PERSONAL.XLSB)
και αποθηκεύεις το φύλλο σε νέο βιβλίο σε συγκεκριμένη διαδρομή και με όνομα που προέρχεται από συγκεκριμένο κελί.

Το παραδειγματικό αρχείο *.xlsm που επισυνάπτω κάνει τα παραπάνω αυτόνομα χωρίς τη βοήθεια άλλων βιβλίων ,και χωρίς να χρειαστεί
να ανοιχτεί το Delivery.xlsx.

Δεν περιέχει εξωτερικές συνδέσεις κελιών αλλά συνδέεται με συγκεκριμένες στήλες του Delivery.xlsx με τη μέθοδο εισαγωγής
εξωτερικών δεδομένων (ODBC;DSN).

Τα δεδομένα αυτά βρίσκονται σε πίνακα (Αντικείμενο λίστας). Αυτό παρέχει μεγάλη ευκολία και ταχύτητα κατά τη εκτέλεση του κώδικα.

Στο αρχείο αυτό χρησιμοποιείται διαφορετική μέθοδος εύρεσης τμημάτων που περιέχουν τα "Keywords" που είναι κατά 400% ταχύτερη
από εκείνη που εφαρμόζεται στη μακροεντολή Bold_Italic_Keywords().

Επίσης περιέχεται κώδικας που επιτρέπει την επανασύνδεση του βιβλίο με το αρχείο εξωτερικών δεδομένων αν αυτό δεν βρεθεί στην
προεπιλεγμένη διαδρομή.

Έτσι, όταν ανοίξεις το αρχείο και πατήσεις κάποιο από τα κουμπιά, θα σου ζητηθεί να επιλέξεις το αρχείο που περιέχει τα δεδομένα ( πχ. το Delivery.xlsx ) για να γίνει η επανασύνδεση .

Περισσότερες λεπτομέρειες μπορείς να δεις μέσα στο αρχείο.

Οι τρεις τελευταίες γραμμές της μακροεντολής είναι απενεργοποιημένες.
Αφού κάνεις τις δοκιμές σου και προσαρμόσεις ότι άλλο χρειαστεί μπορείς να τις ενεργοποιήσεις.

Ελπίζω να μπορέσεις να το προσαρμόσεις και να το αξιοποιήσεις κατάλληλα.

Καλή συνέχεια!

Τάσος

Τάσο ένα μεγάλο ευχαριστώ για την άψογη εφαρμογή.

Ερωτήσεις:

1. Πώς θα μπορέσω να εσωκλείσω το όνομα του πλοίου, το Order Code, Order ID χωρίς να χρησιμοποιήσω εξωτερικές συνδέσεις κελιών (συνημμένο).

2. Το αρχείο να σώζεται με το όνομα του κελιού Α7 και Β9 και όχι μόνο Α7.

3. Παρατήρησα όταν εισάγει τα δεδομένα από το «Delivery.xlsx» προσθέτει στο τέλος ένα επιπλέον διάστημα “space”.

4. Εκ παραδρομής στο τέλος το σύνολο είναι «Total ammount” αντί «Total Amount».

5. Η κολόνα Β παρόλο που είναι “wrap text” δεν αυξομειώνεται το ύψος και πρέπει να γίνει χειροκίνητα.

6. Παρατήρησα επίσης σε κάποιες λέξεις κλειδιά τις κάνει bold and italic και άλλες φορές όχι (item 3, 4).

Μία παράκληση Τάσο, επειδή καταλαβαίνω τον κόπο και τον χρόνο που κατανάλωσες και καταναλώνεις θα ήθελα πραγματικά να σε ευχαριστήσω προσωπικά και όχι μόνο μέσω του φόρουμ.

Θανάσης