[VBA] Application-defined or object-defined error

[devcon]

Καλησπέρα,

Χρησιμοποιώ την ακόλουθη συνάρτηση και όλα πηγαίνουν άριστα μέχρι την στιγμή που ζητώ στο 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

[Tasos]

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

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

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

Χρησιμοποιείς συνεχώς 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

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

Τάσος

[devcon]

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

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

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

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

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

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

Θανάσης

[Tasos]

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

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

Μήπως ο κώδικας σου κλείνει και το βιβλίο όπου περιέχεται επομένως δεν μπορεί να τρέξει η τελευταία γραμμή αφού έχει κλείσει και το έργο 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 και διάβασε τη σχετική βοήθεια.

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

Τάσος

[devcon]

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

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

Ως προς το κωδικό που μου ζητάς είναι 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

[devcon]

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

Και χωρίς να απενεργοποιήσω το “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 δεν κλείνει και δίνει σφάλμα.

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

[Tasos]

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

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

Τάσος

[devcon]

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

Θανάσης

[Tasos]

Καλησπέρα!

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

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

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

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

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

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

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

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

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

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

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

Τάσος

[devcon]

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

Ερωτήσεις:

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).

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

Θανάσης