Thema Datum  Von Nutzer Rating
Antwort
Rot Aus zwei Bläätern in zwei neue Blätter
06.02.2017 15:15:49 Daniel
Solved

Ansicht des Beitrags:
Von:
Daniel		 Datum:
06.02.2017 15:15:49		 Views:
1351		 Rating:
     
Antwort:
 Nein
Thema:
Aus zwei Bläätern in zwei neue Blätter
?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
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

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Aus zwei Bläätern in zwei neue Blätter
06.02.2017 15:15:49 Daniel
Solved