Guten Tag, ich habe folgendes Problem:
Ich kopiere von einer Datei1 von Blatt1 in Datei2 auf Blatt1, würde das dann gerne auch von Datei1 BLatt2 machen in Datei 2 Blatt2...
Leider setzt das Programm dort aus.
Den nächsten schritt die Email zu versenden macht es wieder....???
Der Teil der hagt:
'Alle Filter werden ausgeschaltet
.ShowAllData
'Gruppierung ausschalten
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
'Letzte belegte Zeile finden
Tab_End = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Field 12 ist die Spalte "Arbeitsnachweise unterschrieben", geprüft wird auf "x"
ActiveSheet.Range("A2:N" & Tab_End).AutoFilter Field:=12, Criteria1:="x"
'Field 14 ist die Spalte "Abrechnung für Juchem erzeugt"; geprüft wird auf "leer"
ActiveSheet.Range("A2:N" & Tab_End).AutoFilter Field:=14, Criteria1:="="
'Das Ende der "Arbeitsnachweise" wird ermittelt
intZeile = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
'Nur im Datenbereich der Tabelle (>3Zeile) können Daten versendet werden
If intZeile > 3 Then
'Status anpassen
Range("N3:N" & intZeile) = Date
'Es wird der relevante Teil der Liste kopiert
Union(Range("A3:E" & intZeile), Range("G3:H" & intZeile), Range("I:I" & intZeile)).Copy
'Gruppierung einschalten
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
Komplett:
Private Sub CommandButton8_Click()
If MsgBox("Finger weg, und abbrechen klicken!!!!!!!", vbOKCancel, "Abrechnung starten") = vbOK Then
With ThisWorkbook.Sheets("Instrumentlist")
On Error Resume Next
'Alle Filter werden ausgeschaltet
.ShowAllData
'Gruppierung ausschalten
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=3
'Letzte belegte Zeile finden
Tab_End = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Field 32 ist die Spalte "Eingescannt", geprüft wird auf "x"
ActiveSheet.Range("A4:AP" & Tab_End).AutoFilter Field:=32, Criteria1:="x"
'Field 36 ist die Spalte "Kategorie", geprüft wird auf "nicht leer"
ActiveSheet.Range("A4:AP" & Tab_End).AutoFilter Field:=36, Criteria1:="<>"
'Field 41 ist die Spalte "zur Abrechnung"; geprüft wird auf "leer"
ActiveSheet.Range("A4:AP" & Tab_End).AutoFilter Field:=41, Criteria1:="="
'Das Ende der "Instrumentlist" wird ermittelt
intZeile = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
'Nur im Datenbereich der Tabelle (>Zeile5) können Daten versendet werden
If intZeile > 5 Then
With ThisWorkbook.Sheets("Instrumentlist")
'Status anpassen
Range("AO5:AO" & intZeile) = Date
'Es wird der relevante Teil der Liste kopiert
Union(Range("C5:H" & intZeile), Range("J5:J" & intZeile), Range("AJ5:AM" & intZeile)).Copy
'Gruppierung einschalten
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
End With
End If
End If
'Ab hier wird im Datenblatt Blankoprotokoll gearbeiten
Workbooks.Open Filename:=("P:\ISK\PROJEKTE\ASE_PSM5\010 Loopcheck\030 Kaufmänische Abwicklung\Abrechnungstabellen Juchem\Abrechnung_Blanko.xlsx")
With ThisWorkbook.Sheets("Loopcheck")
'Datenblatt wird aktiviert
.Activate
'Zelle A13 wird selektiert
ActiveSheet.Range("A13").Select
'Daten aus Zwischenablage werden eingefügt
ActiveSheet.Paste
'Sortieren
ActiveSheet.Range("A13:k60000").Select
Selection.Sort Key1:=ActiveSheet.Range("H13"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Zelle wählen
ActiveSheet.Range("d10").Select
End With
'Arbeitsblatt wählen
Worksheets("Arbeitsnachweise").Select
'Zelle wählen
ActiveSheet.Range("a4").Select
'Zu anderen Excel Datei wechseln
Windows("MASTER PSM5_Abrechnungsliste.xlsm").Activate
ThisWorkbook.Sheets ("Arbeitsnachweise")
'Arbeitsblatt wählen
Sheets("Arbeitsnachweise").Select
On Error Resume Next
'Alle Filter werden ausgeschaltet
.ShowAllData
'Gruppierung ausschalten
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
'Letzte belegte Zeile finden
Tab_End = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Field 12 ist die Spalte "Arbeitsnachweise unterschrieben", geprüft wird auf "x"
ActiveSheet.Range("A2:N" & Tab_End).AutoFilter Field:=12, Criteria1:="x"
'Field 14 ist die Spalte "Abrechnung für Juchem erzeugt"; geprüft wird auf "leer"
ActiveSheet.Range("A2:N" & Tab_End).AutoFilter Field:=14, Criteria1:="="
'Das Ende der "Arbeitsnachweise" wird ermittelt
intZeile = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row)
'Nur im Datenbereich der Tabelle (>3Zeile) können Daten versendet werden
If intZeile > 3 Then
'Status anpassen
Range("N3:N" & intZeile) = Date
'Es wird der relevante Teil der Liste kopiert
Union(Range("A3:E" & intZeile), Range("G3:H" & intZeile), Range("I:I" & intZeile)).Copy
'Gruppierung einschalten
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
'Ab hier wird im Datenblatt Blankoprotokoll gearbeiten
Windows("Abrechnung_Blanko.xlsx").Activate
ActiveSheet.Paste
Range("C1").Select
'und mit neuem Namen gespeichert
ActiveWorkbook.SaveAs Filename:="P:\ISK\PROJEKTE\ASE_PSM5\010 Loopcheck\030 Kaufmänische Abwicklung\Abrechnungstabellen Juchem\Abrechnung vom " & Format(Now, "dd.mm.yyyy_hh.mm") & " Uhr.xlsx"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
End With
'InitializeOutlook = True
Set MyOutApp = CreateObject("Outlook.Application")
'Nachrichtenobject erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = "Daniel.aust@infraserv-knapsack.de" 'E-Mail senden an
.Subject = "Tagesmeldung vom " & Date '& Time Betreff Zeile
'Hier wird die temporär gespeicherte Datei als
'Attachment zugefügt
.Attachments.Add AWS
'Hier wird eine normale Text Mail erstellt
'.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
'Hier wird die HTML Mail erstellt
.HTMLBody = "Guten Tag, anbei sende ich Ihnen die Tagesmeldung."
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
End With
ActiveWorkbook.Close 'gespeichert Datei wird geschlossen
End If
End With
End Sub
|