Automatiserungsfehler

Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
DeleteMenu
'Menü_Löschen
End Sub
Private Sub Workbook_Open()
CreateMenu
'Menü_Erstellen
End Sub
Function CreateMenu()
Dim HelpMenu As CommandBarControl
Dim NewMenu As CommandBarPopup
Dim MenuItem As CommandBarControl
Dim Submenuitem As CommandBarButton
Set HelpMenu = Application.CommandBars(1).FindControl(ID:=30010)
If HelpMenu Is Nothing Then
Set NewMenu = Application.CommandBars(1).Controls _
.Add(Type:=msoControlPopup, Temporary:=True)
Else
Set NewMenu = Application.CommandBars(1).Controls _
.Add(Type:=msoControlPopup, Before:=HelpMenu.Index, Temporary:=True)
End If
NewMenu.Caption = "&Einzelpreis Aktualisierung"
Set MenuItem = NewMenu.Controls.Add(Type:=msoControlButton)
With MenuItem
.Caption = "Jetzt Aktualisieren"
.OnAction = "setVisible"
End With
End Function
Function DeleteMenu()
On Error Resume Next
Application.CommandBars(1).Controls("Einzelpreis Aktualisierung").Delete
End Function

Option Explicit
Sub setVisible()
    frmAbfrage.Show
End Sub
Sub setPreisAktuVisible()
    frmPreisAktu.Show
End Sub

Private Sub cmdYes_Click()“ kracht es auf dem CAD Rechner gerade. Und zwar ohne das die form überhaupt sichtbar wird.
<FONT FACE="Courier New,FixedSys"Size=2>
<Blockquote>
<FONT COLOR=#0000FF>Private Sub</FONT> cmdNo_Click()
    Me.Hide
    <FONT COLOR=#0000FF>End</FONT>
End Sub

Option Explicit
'Globale Variablen und Konstanten
Dim strOriginalPath As String 'Pfad der Datei die Aktualisiert wird
Dim strOriginalWorkbook As String 'Name des Workbooks das aktualisiert wird
Dim strOriginalWorksheet As String 'Name der Tabelle die aktualisiert wird
Dim strNewPath As String ' Pfad der Datei aus der Aktualisiert wird
Dim strNewWorkbook As String 'Name des Workbooks aus dem Aktualisiert wird
Dim strNewWorksheet As String 'Name der Tabelle aus der aktualisiert wird
Dim intPreisSpalteNeu As Integer 'Spalte in der neuen datei wo der Preis steht
Dim intArtikelSpalteNeu As Integer 'Spalte in der neuen Datei wo die Artikel Nummer steht
Dim dblEintraege As Double 'Anzahl der Einträge in der neuen Tabelle (anzahl der Zeilen)
Dim dblCopyArtikelSpalte As Double 'Spalte in die die Artikelnummer zwecks schnellerer bearbeitung kopiert wird
Dim blnOperationComplete As Boolean 'suchen und ersetzen abgeschlossen
Dim dtmAnfangszeit As Date, dtmEndzeit As Date, dtmDauer As Date  'zeiten zur dauerberechnung
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Sub UserForm_Activate()
    Call WriteOldNames 'schreibt alle namen der alten datei in vorgesehene (globale) variablen
    strNewPath = neueDateiAuswahl() 'schreibt den Pfad der Datei aus der akutalisiert wird.
    If strNewPath = "" Then
        MsgBox ("Es ist ein Fehler aufgetreten. Der Vorgang wird abgebrochen.")
        frmPreisAktu.Hide
        Exit Sub    'unschön, ich weis. aber ich weis mir nicht anders zu helfen.
    End If
    Workbooks.Open strNewPath 'öffnet die Aktualisierunsdatei
    Call WriteNewNames 'schreibt alle namen der Aktualisierungsdatei in vorgesehen (globale) variablen
    prgGesamtfortschritt.Value = 0  'fortschrittsanzeige auf null setzen
    prgGesamtfortschritt.Max = fctEstimateLoops 'setzt den Maximalwert auf die Anzahl der durchläufe
    Call DateiAktivieren(1)
End Sub
Private Sub cmdWeiter_Click()
'die spalte für den preis und die für die artikelnummer wird zwecks weiterverarbeitung
'gespeichert. eine eingabe von "nichts" wird verhindert.
'anschließend wir die sortierfunktion aufgerufen
    Dim blnGoOn As Boolean
    cmdWeiter.Enabled = False   'deaktiviert den "weiter" button
    blnGoOn = True
    blnOperationComplete = False
    '####   Überprüfen des vorhandenseins der Eingabe der "Preis Spalte" und deren korrektheit
    If txtPreisSpalte.Text <> "" Then        'Die Schleife fängt ab das keine Eingabe gemacht wurde
        txtPreisSpalte.Enabled = False
        intPreisSpalteNeu = ConverseToInt(txtPreisSpalte.Text)
        If CheckInput(intPreisSpalteNeu) = False Then   'Prüft ob die Eingabe Gültig ist
            blnGoOn = False
            MsgBox ("Sie haben eine ungültige oder keine Eingabe gemacht. Bitte geben Sie einen Gültigen Wert ein!")
            txtPreisSpalte.Enabled = True
            txtPreisSpalte.SetFocus
        End If
    Else
        blnGoOn = False
    End If
    '####   Ende der Überprüfung
    '####      Überprüfen des vorhandenseins der Eingabe der "Artikel Spalte" und deren korrektheit
    If txtArtikelNr.Text <> "" Then
        txtArtikelNr.Enabled = False         'Die Schleife fängt ab das keine Eingabe gemacht wurde
        intArtikelSpalteNeu = ConverseToInt(txtArtikelNr.Text)
        If CheckInput(intArtikelSpalteNeu) = False Then
            blnGoOn = False
            MsgBox ("Sie haben eine ungültige oder keine Eingabe gemacht. Bitte geben Sie einen Gültigen Wert ein!")
            txtArtikelNr.Enabled = True
            txtArtikelNr.SetFocus
        End If
    Else
        blnGoOn = False
    End If
    '####   Ende der Überprüfung
    If blnGoOn Then     'Wenn alles in Ordnung
        MsgBox ("Es wird nun aktualisiert. Das kann eine Weile dauern!")
        dtmAnfangszeit = DateTime.Now       'just for testing
        Call fctCopyToOriginal(intArtikelSpalteNeu, intPreisSpalteNeu)  'Kopiere die daten ins original (ist schneller)
        Call fctFillSpaces 'Füllt leere Zellen auf damit das programm durchläuft
        Call fctSerachAndReplace(intPreisSpalteNeu, intArtikelSpalteNeu)  'rufe die "suche und ersetze funktion" auf
    Else
        MsgBox ("Sie haben in einem oder mehreren Feldern keine Eingabe gemacht. Bitte machen sie eine Eingabe!")
        cmdWeiter.Enabled = True
    End If
    If blnOperationComplete = True Then     'wenn suchen und ersetzen fertig dann:
        dtmDauer = (dtmEndzeit - dtmAnfangszeit) 'just for testing
        MsgBox ("Und so lang hat's gedauert: " & dtmDauer) 'just for testing
        Application.ActiveWorkbook.Save     'und schön speichern ^^
        frmPreisAktu.Hide   'verdecke die Form
        End                 'beende das Programm
    End If
    MsgBox (dtmDauer)
End Sub
Function neueDateiAuswahl() As String
    Dim dname
    Dim dfilters$
    dfilters = "Excel-Dateien(*.xls), *.xls"
    dname = Application.GetOpenFilename(dfilters)
    If dname = False Then Exit Function
    neueDateiAuswahl = dname
End Function
Function DateiAktivieren(ByVal intWelcheDatei As Integer) 'mit 0 für die alte und 1 für die neue datei
    Dim xlsDatei As Workbook
    On Error Resume Next
    Select Case intWelcheDatei
        Case 0
            For Each xlsDatei In Workbooks
                If xlsDatei.Name = strOriginalWorkbook Then
                xlsDatei.Activate
                Exit Function
                End If
            Next
        Case 1
            For Each xlsDatei In Workbooks
                If xlsDatei.Name = strNewWorkbook Then
                xlsDatei.Activate
                Exit Function
                End If
            Next
    End Select
End Function
Function fctSerachAndReplace(ByVal strPreisSpalteNeu As String, ByVal strArtikelSpalteNeu As String) As Integer
    'Preisspalte ist die vom benutzer ausgewählte spalte mit dem preis
    'ArtikelNrSpalte auch
    Dim i As Double, n As Double  'Zählvariablen
    Dim dblVerglichene As Double 'Anzahl der Verglichenen Artikel
    Dim dblCount As Double 'doubleInt zum durchzählen der geänderten einträge
    Dim dblNoPriceCount As Double 'doubleInt zum durchzählen der Einträge ohnen Preis
    Dim strArtikelNrAlt As String, strArtikelNrNeu As String 'strings in die die artikel nummern zwecks vergleich geschrieben werden
    Dim strPreisAlt As String, strPreisNeu As String        'strings in die die Preise zwecks vergleich geschrieben wird
    Const intArtikelSpalteAlt As Integer = 6 'Spalte "f" (Bestellnummer[207])
    Const intPreisSpalteAlt As Integer = 17 'Spalte "Q" (Einkaufspreis/Einheit, Währung 1[267])
    i = 2 '2 entspricht auch Zeile 2 (die erste mit einem relevanten Wert)
    Call DateiAktivieren(0) ' aktiviert die alte datei zur bearbeitung
    Worksheets(strOriginalWorksheet).Cells(1, 1).Activate 'aktiviere die erste zelle
    Do While ActiveCell(i, intArtikelSpalteAlt) <> ""
        strArtikelNrAlt = Cells(i, intArtikelSpalteAlt)
        n = 1
        Do While ActiveCell(n, dblCopyArtikelSpalte) <> ""
            strArtikelNrNeu = ActiveCell(n, dblCopyArtikelSpalte)
            If strArtikelNrAlt = strArtikelNrNeu Then
                strPreisNeu = Cells(n, (dblCopyArtikelSpalte + 1))
                If CheckPrice(strPreisNeu) Then 'wenn es einen Preis gibt
                    Cells(i, intPreisSpalteAlt) = strPreisNeu   'schreib ihn in die ensprechende spalte
                    dblCount = dblCount + 1     'und merk dir das du es getan hast
                    Exit Do                     'unschön aber schnell
                Else
                    dblNoPriceCount = dblNoPriceCount + 1   'wenn es keinen Preis gibt merk dir das
                End If
                Exit Do                         'unschön aber schnell
            End If
            n = n + 1
        Loop
        i = i + 1
        prgGesamtfortschritt.Value = i
        prgGesamtfortschritt.Refresh
    Loop
    Range(Cells(1, dblCopyArtikelSpalte), Cells(dblEintraege, dblCopyArtikelSpalte)).Clear  'löscht die eingetragenen "neuen" artikelnummern
    Range(Cells(1, (dblCopyArtikelSpalte + 1)), Cells(dblEintraege, (dblCopyArtikelSpalte + 1))).Clear 'löscht die eingetragenen "neuen" preise
    DateiAktivieren (1)
    ActiveWorkbook.Close 'schließt die datei mit den aktualisierungsdaten
    dtmEndzeit = DateTime.Now
    dblVerglichene = i - 1
    MsgBox ("Es wurden " & dblVerglichene & " Einträge Verglichen." & vbCr & _
        dblCount & " Einträge wurden aktualisiert und" & vbCr & _
        dblNoPriceCount & " gefundene Einträge waren ohne Preis " & vbCr & _
        "und wurden nicht aktualisiert!")
    blnOperationComplete = True     'suchen und ersetzen ist fertig!
End Function
Function WriteOldNames() As Boolean
'Diese function schreibt den Pfad, den Namen der alten Arbeitsmappe und den Namen der Tabelle in
'die dafür vorgesehen Variablen.
    strOriginalPath = ActiveWorkbook.FullName 'Pfad der Original Datei
    strOriginalWorkbook = ActiveWorkbook.Name 'Name der Original Datei
    strOriginalWorksheet = ActiveSheet.Name        'Name des Tabelle
End Function
Function WriteNewNames() As Boolean
'Diese function schreibt den Pfad, den Namen der neuen Arbeitsmappe und den Namen der Tabelle in
'die dafür vorgesehen Variablen.
    strNewWorkbook = ActiveWorkbook.Name     'Name der Datei aus der aktualisiert wird
    strNewWorksheet = ActiveSheet.Name       'Name der Tabelle aus der aktualisiert wird
End Function
Function ConverseToInt(ByVal strToConverse As String) As Integer
'Diese Funktion wandelt eingegebene Buchstaben (nur "a" bis "z" bzw. "A" bis "Z") in integer um
    Dim intRetValue As Integer
    intRetValue = Asc(strToConverse)
    If intRetValue >= 65 And intRetValue <= 90 Then
        intRetValue = intRetValue - 64
    End If
    If intRetValue >= 97 And intRetValue <= 122 Then
        intRetValue = intRetValue - 96
    End If
    ConverseToInt = intRetValue
End Function
Function CheckInput(ByVal intInput As Integer) As Boolean
'diese Funktion überprüft die Eingabe auf zulässigkeit
    If intInput < 1 Or intInput > 26 Then
        CheckInput = False
    Else
        CheckInput = True
    End If
End Function
Function CheckPrice(ByVal strPrice As String) As Boolean
'Diese Funktion überprüft ob es für den Entsprechenden Artikel einen Preiseintrag gibt
    If strPrice <> "" Then  'wenn es einen Preis gibt
        CheckPrice = True   'dann ist das so
    Else                    'ansonsten
        CheckPrice = False  'gibt es keinen
    End If
End Function
Function fctCopyToOriginal(ByVal intArtikelSpalte As Integer, ByVal intPreisSpalte As Integer) As Boolean
'Diese Funktion kopiert die Daten zwecks schnellerer Bearbeitung in die Original Tabelle
    Dim z As Double
    Dim x As Double
    dblCopyArtikelSpalte = 1
    Call DateiAktivieren(0) 'aktiviert die original datei
    Worksheets(strOriginalWorksheet).Cells(1, 1).Activate 'aktiviert die erste zelle (1,1)
    z = 1
    Do While ActiveCell(1, z) <> ""     'Diese Schleife findet herraus Welche Spalte zum einfügen frei ist
        dblCopyArtikelSpalte = dblCopyArtikelSpalte + 1
        z = z + 1
    Loop
    Call DateiAktivieren(1) 'aktiviert die neue datei
    z = 1
    Worksheets(strNewWorksheet).Cells(1, 1).Activate 'aktiviert die erste zelle (1,1)
    Do While ActiveCell(z, intArtikelSpalte) <> ""     'Diese schleife findet heraus wieviele einträge in der spalte stehen
        dblEintraege = dblEintraege + 1
        z = z + 1
    Loop
    Range(Cells(1, intArtikelSpalte), Cells(dblEintraege, intArtikelSpalte)).Copy 'kopiert alle artikel nummern
                                                                                  'in die zwischenablage
    Call DateiAktivieren(0) 'aktiviert die alte datei
    Range(Cells(1, dblCopyArtikelSpalte), Cells(dblEintraege, dblCopyArtikelSpalte)).PasteSpecial 'fügt artikel nummern
                                                                                                  'aus der z-ablage ein
    Call DateiAktivieren(1) 'aktiviert die neue datei
    Range(Cells(1, intPreisSpalte), Cells(dblEintraege, intPreisSpalte)).Copy     'kopiert alle preise in die z-ablage
    Call DateiAktivieren(0) 'aktiviert die alte datei
    Range(Cells(1, (dblCopyArtikelSpalte + 1)), Cells(dblEintraege, (dblCopyArtikelSpalte + 1))).PasteSpecial 'fügt preise
                                                                                                'aus der z-ablage ein
    Call EmptyClipboard     'zwischenablage leeren
End Function
Function fctFillSpaces() As Boolean
'Diese Funktion geht die alte Artikelspalte durch und füllt leere Spalten mit Text.
    Dim i As Double, dblSpalte As Double
    i = 1
    Call DateiAktivieren(0) ' aktiviert die alte datei zur bearbeitung
    Worksheets(strOriginalWorksheet).Cells(1, 1).Activate 'aktiviere die erste zelle
    Do While ActiveCell(i, 4) <> ""
        If ActiveCell(i, 6) = "" Then
            ActiveCell(i, 6) = "keine Nummer vorhanden"
        End If
        i = i + 1
    Loop
End Function
Function fctEstimateLoops() As Double
'Diese Funktion berechnet die benötigten durchgänge. Das wird dann für die "Status Bar" anzeige benötigt.
    Dim dblLoops As Double  'anzahl der schleifen
    Call DateiAktivieren(0) 'aktiviert die alte datei
    Worksheets(strOriginalWorksheet).Cells(1, 1).Activate 'aktiviere die erste zelle
    dblLoops = 1
    Do While ActiveCell(dblLoops, 6) <> ""
        dblLoops = dblLoops + 1
    Loop
    fctEstimateLoops = dblLoops 'rückgabewert
End Function