Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/OLE / Макрос ошибкa в коде - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Вопросы по Excel для Mac » OLE / Макрос ошибкa в коде (Makros VB OLE / Макрос ошибкa в коде)
OLE / Макрос ошибкa в коде
Roman090783 Дата: Четверг, 06.06.2019, 11:18 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
Уважаемые Эксперты Макроса, Excel и VBA,
прошу помочь разобраться с ошибкой в коде. Проблема в том, что после того как я в документе даю команду "нажмите дважды" должно печатать документ, но при подтверждении в окне печати я попадаю в бесконечный цикл и после чего зависает Макрос и выходит окно с такой ошибкой: "Microsoft Excel ожидает завершения ole-действия в другом приложении."
Я предполагаю, что в этой части кода есть ошибка:

[vbа][cоde]

Sub Auswahl_Arbeitsblatt(ByVal R_Target As Range, ByRef Bezeichner As String, ByRef AktZeile As Long)
' Routine ermittelt nach Selektion den Bezeichner für die Drucküberschrift und die ausgewählte Zeile
' ___________________________________________________________________________________________________
Dim C As Long
Dim R As Long
Dim Teil1 As String
Dim Teil2 As String
Dim Delimiter As String

On Error GoTo err_exit
Bezeichner = ""
AktZeile = 0
If R_Target.Row < 4 Then Exit Sub ' nur ab 4.Zeile

' Einzelzeile übernehmen
R = R_Target.Row
'nur bei Doppelklick in Spalte 4

C = R_Target.Column
If C <> 4 Then
Exit Sub
End If
' Ausgabe selektierte Zeile
AktZeile = R
l = 1
' Bezeichner zusammensetzen (1 links und aktuelle Zelle)
Teil1 = ActiveCell.Offset(0, -1)
Teil2 = ActiveCell.Offset(0, 0)
' Ausgabe Bezeichner
If Teil1 <> "" And Teil2 <> "" Then
Delimiter = " - "
Bezeichner = Trim(Teil1) + Delimiter + Trim(Teil2)
Else
MsgBox "Auwahl nicht erfolgreich!", vbCritical
AktZeile = 0
Exit Sub
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & "Auswahl_Arbeitsblatt" & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"
End Sub
Sub Dateiname_bereitstellen(Index As Integer, Dateiname As String, KZ_Inventur As Integer)
' Aus der Konfiguration wird der Dateiname ermittelt
' _______________________________________________________________
Dim TB2 As Worksheet
Dim Delimiter As String
Dim Datei As String
Dim Pfad As String
Dim lngRow As Long
Dim Vgl As Integer
Dim Anz As Integer
Dim Steuerung As Variant

On Error GoTo err_exit
Dateiname = ""
KZ_Inventur = 0
Set TB2 = ActiveWorkbook.Sheets(2)

With TB2
Anz = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngRow = 2 To Anz
If .Cells(lngRow, 1).Value = "Quellverzeichnis" Then
Pfad = .Cells(lngRow, 3).Value
Delimiter = Right(Pfad, l)
If Delimiter <> "\" Then
Pfad = Trim(Pfad) + "\"
End If
End If
Steuerung = Trim(.Cells(lngRow, 1).Value)
If lngRow = 24 Then
KZ_Inventur = 0
End If
If Steuerung = "Mapping" Or Steuerung = "Inventur" Then
Vgl = CInt(.Cells(lngRow, 2).Value)
If Steuerung = "Inventur" Then
KZ_Inventur = 1
End If
If Vgl = Index Then
Datei = .Cells(lngRow, 3).Value
Exit For
End If
End If
Next
End With
' Wenn Kein Eintrag für Datei, wird Dateiname insgesamt auf Leerwert gesetzt
If Datei = "" Then
Dateiname = ""
Else
Dateiname = Pfad + Datei
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & "Dateiname bereitstellen" & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"
End Sub
Sub Dateien_Drucken(Bezeichnung As String, AktZeile As Long)
' Umfassende Routine zur Verarbeitung nach Konfiguration
' __________________________________________________________
Dim TB As Worksheet
Dim Von As Integer
Dim Bis As Integer
Dim Anz As Integer
Dim Inh As Variant
Dim Z As Integer
Dim Inventur_Kennung As Integer

Dim lngRow As Long

Dim Dateiname As String
Dim KZ_Inventur As Integer
Dim Fehler As Boolean
Dim Dt_Wert As Variant

Fehler = False
On Error GoTo err_exit

' Konfiguration durchsuchen
Set TB = ActiveWorkbook.Sheets(2)

With TB
Anz = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngRow = 2 To Anz
If .Cells(lngRow, 1).Value = "Bereich von" Then
Von = CInt(.Cells(lngRow, 2).Value)
End If
If .Cells(lngRow, 1).Value = "Bereich bis" Then
Bis = CInt(.Cells(lngRow, 2).Value)
End If
If Von > 0 And Bis > 0 Then
Exit For
End If
Next
End With
' Zeile in Tabelle 1 durchsuchen
Set TB = ActiveWorkbook.Sheets(1)
For Z = Von To Bis
Inh = ""
Inh = TB.Cells(AktZeile, Z).Value
If Inh > "" And Inh <> "0" Then
' Dateiname ermitteln
Call Dateiname_bereitstellen(Z, Dateiname, KZ_Inventur)
'Wenn Inveturliste in Vergangenheit schon einmal ausgedruckt wurde, kein weiterer Ausdruck
Dt_Wert = TB.Cells(AktZeile, Bis + 1).Value

If Dt_Wert = "" Then
Dt_Wert = Date + 1
End If

If KZ_Inventur = 1 And Dt_Wert <= Date Then
' kein Ausdruck
Else
If Dateiname <> "" Then
' Datei ausdrucken
Call Mappe_oeffnen(Dateiname, Bezeichnung, Fehler)
Inventur_Kennung = KZ_Inventur
End If
End If
End If
If Fehler Then
Exit For
End If
Next
If Not Fehler Then
If Inventur_Kennung = 1 Then
TB.Cells(AktZeile, Bis + 1).Value = Date
End If
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & "Dateien drucken" & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"

End Sub

[/cоde][/vbа]
К сообщению приложен файл: 7948698.jpg(82.3 Kb)


95074

Сообщение отредактировал Roman090783 - Четверг, 06.06.2019, 12:34
 
Ответить
СообщениеУважаемые Эксперты Макроса, Excel и VBA,
прошу помочь разобраться с ошибкой в коде. Проблема в том, что после того как я в документе даю команду "нажмите дважды" должно печатать документ, но при подтверждении в окне печати я попадаю в бесконечный цикл и после чего зависает Макрос и выходит окно с такой ошибкой: "Microsoft Excel ожидает завершения ole-действия в другом приложении."
Я предполагаю, что в этой части кода есть ошибка:

[vbа][cоde]

Sub Auswahl_Arbeitsblatt(ByVal R_Target As Range, ByRef Bezeichner As String, ByRef AktZeile As Long)
' Routine ermittelt nach Selektion den Bezeichner für die Drucküberschrift und die ausgewählte Zeile
' ___________________________________________________________________________________________________
Dim C As Long
Dim R As Long
Dim Teil1 As String
Dim Teil2 As String
Dim Delimiter As String

On Error GoTo err_exit
Bezeichner = ""
AktZeile = 0
If R_Target.Row < 4 Then Exit Sub ' nur ab 4.Zeile

' Einzelzeile übernehmen
R = R_Target.Row
'nur bei Doppelklick in Spalte 4

C = R_Target.Column
If C <> 4 Then
Exit Sub
End If
' Ausgabe selektierte Zeile
AktZeile = R
l = 1
' Bezeichner zusammensetzen (1 links und aktuelle Zelle)
Teil1 = ActiveCell.Offset(0, -1)
Teil2 = ActiveCell.Offset(0, 0)
' Ausgabe Bezeichner
If Teil1 <> "" And Teil2 <> "" Then
Delimiter = " - "
Bezeichner = Trim(Teil1) + Delimiter + Trim(Teil2)
Else
MsgBox "Auwahl nicht erfolgreich!", vbCritical
AktZeile = 0
Exit Sub
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & "Auswahl_Arbeitsblatt" & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"
End Sub
Sub Dateiname_bereitstellen(Index As Integer, Dateiname As String, KZ_Inventur As Integer)
' Aus der Konfiguration wird der Dateiname ermittelt
' _______________________________________________________________
Dim TB2 As Worksheet
Dim Delimiter As String
Dim Datei As String
Dim Pfad As String
Dim lngRow As Long
Dim Vgl As Integer
Dim Anz As Integer
Dim Steuerung As Variant

On Error GoTo err_exit
Dateiname = ""
KZ_Inventur = 0
Set TB2 = ActiveWorkbook.Sheets(2)

With TB2
Anz = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngRow = 2 To Anz
If .Cells(lngRow, 1).Value = "Quellverzeichnis" Then
Pfad = .Cells(lngRow, 3).Value
Delimiter = Right(Pfad, l)
If Delimiter <> "\" Then
Pfad = Trim(Pfad) + "\"
End If
End If
Steuerung = Trim(.Cells(lngRow, 1).Value)
If lngRow = 24 Then
KZ_Inventur = 0
End If
If Steuerung = "Mapping" Or Steuerung = "Inventur" Then
Vgl = CInt(.Cells(lngRow, 2).Value)
If Steuerung = "Inventur" Then
KZ_Inventur = 1
End If
If Vgl = Index Then
Datei = .Cells(lngRow, 3).Value
Exit For
End If
End If
Next
End With
' Wenn Kein Eintrag für Datei, wird Dateiname insgesamt auf Leerwert gesetzt
If Datei = "" Then
Dateiname = ""
Else
Dateiname = Pfad + Datei
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & "Dateiname bereitstellen" & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"
End Sub
Sub Dateien_Drucken(Bezeichnung As String, AktZeile As Long)
' Umfassende Routine zur Verarbeitung nach Konfiguration
' __________________________________________________________
Dim TB As Worksheet
Dim Von As Integer
Dim Bis As Integer
Dim Anz As Integer
Dim Inh As Variant
Dim Z As Integer
Dim Inventur_Kennung As Integer

Dim lngRow As Long

Dim Dateiname As String
Dim KZ_Inventur As Integer
Dim Fehler As Boolean
Dim Dt_Wert As Variant

Fehler = False
On Error GoTo err_exit

' Konfiguration durchsuchen
Set TB = ActiveWorkbook.Sheets(2)

With TB
Anz = .Cells(.Rows.Count, 1).End(xlUp).Row
For lngRow = 2 To Anz
If .Cells(lngRow, 1).Value = "Bereich von" Then
Von = CInt(.Cells(lngRow, 2).Value)
End If
If .Cells(lngRow, 1).Value = "Bereich bis" Then
Bis = CInt(.Cells(lngRow, 2).Value)
End If
If Von > 0 And Bis > 0 Then
Exit For
End If
Next
End With
' Zeile in Tabelle 1 durchsuchen
Set TB = ActiveWorkbook.Sheets(1)
For Z = Von To Bis
Inh = ""
Inh = TB.Cells(AktZeile, Z).Value
If Inh > "" And Inh <> "0" Then
' Dateiname ermitteln
Call Dateiname_bereitstellen(Z, Dateiname, KZ_Inventur)
'Wenn Inveturliste in Vergangenheit schon einmal ausgedruckt wurde, kein weiterer Ausdruck
Dt_Wert = TB.Cells(AktZeile, Bis + 1).Value

If Dt_Wert = "" Then
Dt_Wert = Date + 1
End If

If KZ_Inventur = 1 And Dt_Wert <= Date Then
' kein Ausdruck
Else
If Dateiname <> "" Then
' Datei ausdrucken
Call Mappe_oeffnen(Dateiname, Bezeichnung, Fehler)
Inventur_Kennung = KZ_Inventur
End If
End If
End If
If Fehler Then
Exit For
End If
Next
If Not Fehler Then
If Inventur_Kennung = 1 Then
TB.Cells(AktZeile, Bis + 1).Value = Date
End If
End If
Exit Sub
err_exit:
MsgBox "Fehler: " & CStr(Err.Number) & vbLf & "Dateien drucken" & vbLf & _
Err.Description, vbCritical, "Fehlermeldung"

End Sub

[/cоde][/vbа]

Автор - Roman090783
Дата добавления - 06.06.2019 в 11:18
китин Дата: Четверг, 06.06.2019, 11:23 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 5913
Репутация: 920 ±
Замечаний: 0% ±

Excel 2007;Excel 2010
Roman090783, читаем Правила форума особенно п.2 и п.3. Оформлям код тэгами пояснялка здесь. и прикладываем файл пример.
а также смотрим п.2 в части названия темы и меняем свое невнятное название
и кстати да : а почему в разделе Вопросы по Excel для Mac? у вас Mac?


Не судите строго:я пытаюсь научиться
ЯД 41001877306852/WM R249698041931; Z239672726538
 
Ответить
СообщениеRoman090783, читаем Правила форума особенно п.2 и п.3. Оформлям код тэгами пояснялка здесь. и прикладываем файл пример.
а также смотрим п.2 в части названия темы и меняем свое невнятное название
и кстати да : а почему в разделе Вопросы по Excel для Mac? у вас Mac?

Автор - китин
Дата добавления - 06.06.2019 в 11:23
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Вопросы по Excel для Mac » OLE / Макрос ошибкa в коде (Makros VB OLE / Макрос ошибкa в коде)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2019 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!