Habe jetzt hinter jedem Befehl eine Msg-Box eingestellt. Starte ich das Makro jetzt, läuft es auch ohne Probleme durch. Irgendwo sieht es so aus, als hätte der Programmablauf ein Zeitproblem. Wie kann ich die Ursache herausfinden?
Gruß Hartmut
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
Sub Hauptdatei()
Const ZIELDATEI$ = "I:\HKS_Fachkontrolle\3_VGV-LW-Qualität\Besichtigungskriterien\ _
Besichtigungskriterien.xlsx"
Dim WbQ As Workbook: Set Wqb = ThisWorkbook
Dim WbZ As Workbook
Dim WsQ As Worksheet: Set WsQ = Wb.Worksheets("Final")
Dim WsZ As Worksheet
Application.ScreenUpdating = False
With WsQ
If .AutoFilterMode Then .ShowAllData
If .Range("E2").Value "" Then .Range("E2").Offset(0, -4) = "Angenendt"
.Range("A2:M" & .UsedRange.Rows.Count).SpecialCells(xlCellTypeVisible).Copy
End With
Set WbZ = Workbooks.Open(Filename:=ZIELDATEI)
With WbZ.Worksheets("Tabelle1")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlValues
End With
WbZ.Close True
Application.CutCopyMode = False
Set WbQ = Nothing: Set WbZ = Nothing: Set WsQ = Nothing: Set WsZ = Nothing
End Sub
Der Zeilenumbruch bei der Konstante mit dem Zielpfad ist der Forumssoftware geschuldet; den musst Du in VBA dann entfernen, sodass die Konstantenzuweisung nur einzeilig ist.