AW: Zeig mal den Code, wir sind keine Hellseher! owT
29.08.2017 11:45:13
Hartmut_M
Hallo Michael, hier der Code. Habe jetzt noch eine msgbox mit der Fehlerbeschreibung eingebunden.
Als Fehler wird ausgegeben: "1004 Die Methode 'Open' für das Object 'Workbooks' ist fehlgeschlagen.
In Google habe ich einen Hinweis gefunden, dass es damit zusammen hängen kann, dass der Focus noch auf der Schaltfläche liegt und Excel da nichts anderes machen kann. Allerdings läuft es, wie beschrieben, bei mir auf dem PC auch bei Betätigen der Schaltfläche.
Sub Sammeldatei()
On Error GoTo fehler
'ausgeblendete Spalten einblenden
Columns("A:C").Hidden = False
Columns("F:F").Hidden = False
'Filter setzen auf "n"
ActiveSheet.Range("$A$1:$M$1000").AutoFilter Field:=7, Criteria1:="nein"
If ActiveSheet.Cells(65536, 7).End(xlUp).Row > 1 Then
ActiveSheet.Range("A1:H" & ActiveSheet.UsedRange.Rows.Count). _
SpecialCells(xlCellTypeVisible).Copy
Worksheets("Sammeldatei").Visible = True
Worksheets("Sammeldatei").Select
Worksheets("Sammeldatei").Range("A1").PasteSpecial xlValues
Application.CutCopyMode = False
'Übertrag für Sammeldatei vorbereiten
Worksheets("Sammeldatei").Visible = True
Worksheets("Sammeldatei").Columns("A:C").Select
Selection.Delete Shift:=xlToLeft
Worksheets("Sammeldatei").Columns("B:B").Select
Selection.Insert Shift:=xlToRight
Worksheets("Sammeldatei").Range("B1").Select
ActiveCell.FormulaR1C1 = "Sparte"
Worksheets("Sammeldatei").Columns("D:D").Select
Selection.ClearContents
Worksheets("Sammeldatei").Range("D1").Select
ActiveCell.FormulaR1C1 = "VN"
Worksheets("Sammeldatei").Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Worksheets("Sammeldatei").Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Worksheets("Sammeldatei").Range("G1").Select
ActiveCell.FormulaR1C1 = "Mangel"
Worksheets("Sammeldatei").Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Worksheets("Sammeldatei").Range("I1").Select
ActiveCell.FormulaR1C1 = "Kommentar"
Worksheets("Sammeldatei").Range("F1") = "Art"
Worksheets("Sammeldatei").Range("M1") = "Name"
Worksheets("Sammeldatei").Range("N1") = "Datum"
Worksheets("Sammeldatei").Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Worksheets("Sammeldatei").Range("A2").Activate
10:
If ActiveCell "" Then
ActiveCell.Offset(0, 1).Value = "Sach"
ActiveCell.Offset(0, 5).Value = "LW"
ActiveCell.Offset(0, 6).Value = "Besichtigungsqualität"
ActiveCell.Offset(0, 13).Value = Revisor
ActiveCell.Offset(0, 14).Value = Date
ActiveCell.Offset(1, 0).Activate
GoTo 10
End If
'Daten werden kopiert
ActiveSheet.Range("A2:O" & ActiveSheet.UsedRange.Rows.Count). _
SpecialCells(xlCellTypeVisible).Copy
'Öffnet die Sammeldatei und fügt die Daten an.
'Der Pfad muss angepasst werden, wenn die Datei an einem anderen Ort abgelegt/umbenannt wird
Workbooks.Open Filename:="I:\HKS_Fachkontrolle\1_Externe_Fachkontrolle\11_Außendienst\ _
113_Erfassung_und_Auswertung\Sammeldatei.xlsm"
'Öffnet immer in das erste Tabellenblatt (unabhängig vom Namen)
Worksheets(1).Select
'Sucht die nächste freie Zelle
With Worksheets("Berichte")
iletzteZelle = .Cells(.Rows.Count, 1).End(xlUp).Row
'Fügt den Zelleninhalte als "Werte" ein
.Cells(iletzteZelle + 1, 1).PasteSpecial Paste:=xlValues
End With
Workbooks("Sammeldatei.xlsm").Close savechanges:=True
Application.CutCopyMode = False
Worksheets("Sammeldatei").Visible = False
MsgBox "Ihre Daten wurden in die Sammeldatei übertragen!" & vbCrLf & "Jetzt erfolgt noch _
der Eintrag in die Hauptdatei!"
End If
Hauptdatei
Exit Sub
fehler:
MsgBox Err.Number & " " & Err.Description
End Sub
Sub Hauptdatei()
Worksheets("Final").Select
Dim aSh As Worksheet
Set aSh = ActiveSheet
If aSh.FilterMode Then aSh.ShowAllData
Set aSh = Nothing
Range("E2").Activate
10:
If ActiveCell "" Then
ActiveCell.Offset(0, -4).Value = "Angenendt"
ActiveCell.Offset(1, 0).Activate
GoTo 10
End If
ActiveSheet.Range("A2:M" & ActiveSheet.UsedRange.Rows.Count). _
SpecialCells(xlCellTypeVisible).Copy
'Öffnet die Hauptdatei und fügt die Daten an.
'Der Pfad muss angepasst werden, wenn die Datei an einem anderen Ort abgelegt/umbenannt wird
Workbooks.Open Filename:="I:\HKS_Fachkontrolle\3_VGV-LW-Qualität\Besichtigungskriterien\ _
Besichtigungskriterien.xlsx"
'Öffnet immer in das erste Tabellenblatt (unabhänig vom Namen)
Worksheets(1).Select
'Sucht die nächste freie Zelle
With Worksheets("Tabelle1")
iletzteZelle = .Cells(.Rows.Count, 1).End(xlUp).Row
'Fügt den Zelleninhalte als "Werte" ein
.Cells(iletzteZelle + 1, 1).PasteSpecial Paste:=xlValues
End With
Workbooks("Besichtigungskriterien.xlsx").Close savechanges:=True
Application.CutCopyMode = False
End Sub