Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1060to1064
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Sortieren, alles in eine Arbeitsmappe und senden

Sortieren, alles in eine Arbeitsmappe und senden
16.03.2009 10:07:39
xen
'########################################################################################################################
'
'KopierenStandortlise
'
' BERECHTIGUNG FÜR C:\Temp prüfen!
'########################################################################################################################
Sub KopierenStandortlise()
Sheets("Auswertung").Activate
Range("A1:F1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Auswertung_sortiert").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2 _
:=xlSortNormal
Range("A1").Select
Versenden
End Sub


'########################################################################################################################
'
'Versenden
'
'########################################################################################################################


Public Sub Versenden()
Dim aktuelleZeile As Long
Dim LetzerStandort As String
Dim start As Long
Dim ende As Long
Sheets("Auswertung_sortiert").Activate
aktuelleZeile = 1
letzterStandort = ActiveSheet.Cells(2, 1).Value
aktuellerStandort = ActiveSheet.Cells(2, 1).Value
start = 2
While ActiveSheet.Cells(aktuelleZeile, 1).Value  ""
aktuelleZeile = aktuelleZeile + 1
aktuellerStandort = ActiveSheet.Cells(aktuelleZeile, 1).Value
If letzterStandort  aktuellerStandort And aktuelleZeile  2 Then
ende = aktuelleZeile - 1
kopiereStandordaten start, ende
start = aktuelleZeile
letzterStandort = aktuellerStandort
End If
Wend
End Sub


'########################################################################################################################
'
'kopiereStandordaten
'
'########################################################################################################################


Public Sub kopiereStandordaten(start As Long, ende As Long)
ActiveSheet.Range(Cells(start, 1), Cells(ende, 6)).Select
Selection.Copy
Sheets("Versandvorlage").Select
Range("A10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("F1").Value = Now
versenden_Arbeitsmappe
ActiveSheet.Range("A10:F500").Select
Selection.Clear
End Sub


'########################################################################################################################
'
'Function FileExist
'
'########################################################################################################################
Function FileExist(ByVal strPath As String) As Boolean
FileExist = Len(Dir$(strPath)) 0
End Function


'########################################################################################################################
'
'kopieren_arbeitsmappe
'
'########################################################################################################################


Public Sub kopieren_arbeitsmappe(druckbereich As String)
On Error GoTo ErrorHandler
Dim WB_Ziel As String
Dim WB_Quelle As String
WB_Quelle = ActiveWorkbook.Name
Workbooks.Add
WB_Ziel = ActiveWorkbook.Name
Windows(WB_Ziel).Activate
Windows(WB_Quelle).Activate
Cells.Select
Selection.Copy
Windows(WB_Ziel).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:= _
False
Windows(WB_Quelle).Activate
Application.CutCopyMode = False
Selection.Copy
Windows(WB_Ziel).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=  _
_
False
Application.CutCopyMode = False
ActiveWindow.Zoom = 75
ActiveWindow.DisplayGridlines = False
'With ActiveWorkbook
'    '.PrecisionAsDisplayed = False
'    .Date1904 = True
'End With
With ActiveSheet.PageSetup
.Zoom = False
.PrintArea = druckbereich
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Cells(1, 1).Select
Exit Sub
ErrorHandler:
Cells(1, 1).Select
MsgBox Err.Description, vbCritical
End Sub


'########################################################################################################################
'
'versenden_Arbeitsmappe
'
'########################################################################################################################


Private Sub versenden_Arbeitsmappe()
Dim empfn As String
Dim i As Integer
Dim betr As String
Dim dateiname_kurz As String
Dim dateiname_lang As String
On Error GoTo e_handler
empfn = Range("B7").Value
betr = "Telefonreporting " & Range("B1").Value & " " & Range("B6").Value & ", " & Range("d1" _
_
).Value
dateiname_kurz = "Telefonreporting_" & "_" & Range("B6").Value & "_"
kopieren_arbeitsmappe "A1:BS200"
dateiname_lang = ThisWorkbook.SaveFileAS(dateiname_kurz)
ActiveWorkbook.SendMail empfn, betr
ActiveWorkbook.Close False
If FileExist(dateiname_lang) Then Kill dateiname_lang
Exit Sub
e_handler:
MsgBox "Fehler beim Versenden der Arbeitsmappe: " & Err.Description
ActiveWorkbook.Close False
If FileExist(dateiname_lang) Then Kill dateiname_lang
End Sub


Mein Problem besteht jetzt darin das das Script nur automatisch eine Email verschickt.
Es sollte allerdings nach der ersten Mail eine nächste neue Mappe generieren und die 2 Mail
rausschicken usw.Das Problem ist in


Public Sub Versenden() bei aktueller Zeile sofern ich mich
nicht irre.
Hat jemand ne vielleicht ne idee?


		

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Sortieren, alles in eine Arbeitsmappe und senden
16.03.2009 16:02:21
fcs
Hallo Xen,
bei der Code-Länge und den vielen Activate/Select von Arbeitsmappen und Tabellenblättern ist es schwierig den Durchblick zu behalten.
Ich sehe 2 mögliche Problemstellen:
1. Nach dem Versand der 1. Mail ist das Blatt "Auswertung_sortiert" nicht das aktive Blatt sondern das Blatt "Versandvorlage". So ergibt

While ActiveSheet.Cells(aktuelleZeile, 1).Value  ""

eine Prüfung auf leere Leere zelle und die Schleife bricht ab.
2. in der Prozedur "Private Sub versenden_Arbeitsmappe()"
ist mir die Zeile


dateiname_lang = ThisWorkbook.SaveFileAS(dateiname_kurz)


sehr suspekt. Warum soll hier die Arbeitsmappe, in der das Makro gespeichert ist, unter einem anderen Namen gespeichert werden?
Müßte es hier nicht ActiveWorkbook statt ThisWorkbook heißen?
Gruß
Franz

Anzeige

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige