Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1360to1364
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

Code erweitern

Code erweitern
08.05.2014 08:26:33
Christian
Hallo zusammen,
wie kann ich diesen Code erweitern, dass sich im neu erstellten Sheet alle Zeilen ab 33 - Ende & alle Spalten ab G bis Ende ausgeblendet oder gelöscht werden?

Private Sub Button_Click()
anzahl = Sheets.Count
Sheets.Add
ActiveSheet.Name = Date
ActiveSheet.Move after:=Sheets(anzahl - 0)
Dim ii As Integer
ii = 1
Xcopy Worksheets("Auswertung").Range("A1:F32"), Worksheets(ii).Cells(1, 1)
End Sub
Private Sub Xcopy(rngSrc As Range, rngDst As Range)
Dim i As Long
rngSrc.Copy rngDst
For i = 1 To rngSrc.Rows.Count
rngDst.Rows(i).RowHeight = rngSrc.Rows(i).RowHeight
Next
For i = 1 To rngSrc.Columns.Count
rngDst.Columns(i).ColumnWidth = rngSrc.Columns(i).ColumnWidth
Next
End Sub

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code erweitern
08.05.2014 08:50:29
Hajo_Zi
Range(Rows(33), Rows(33).End(xlDown)).EntireRow.Hidden = True
Range(Columns(7), Columns(7).End(xlToRight)).EntireColumn.Hidden = True

AW: Code erweitern
08.05.2014 08:56:04
Christian
Geht leider noch nicht. An welche Stelle muss ich diese beiden Zeilen einfügen?

AW: Code erweitern
08.05.2014 09:04:48
Hajo_Zi
vor End Sub
Ich kann es nur an meiner Datei testen, da ich die sehe.
Gruß Hajo

AW: Code erweitern
08.05.2014 09:11:09
Christian
Ich habe es bei beiden End Sub ´s probiert, geht aber bei beiden leider nicht.

AW: Code erweitern
08.05.2014 08:51:06
Christian
Dieser bestehende Code funktioniert leider nur einmal. Sobald ich am nächsten Tag ihn wieder ausführe wird zwar die Registerkarte mit dem richtigen Datum erstellt, jedoch wird nichts kopiert.
Kann mir jemand helfen?

Anzeige
AW: Code erweitern
08.05.2014 09:06:42
Christian
Da ich nur einen Sheet habe geht es einmal, sobald ich 2 oder mehr habe wird nicht mehr kopiert - hilft euch das weiter in der Lösungsfindung?

AW: Code erweitern
08.05.2014 09:40:21
Christian
Habe eine Testdatei erstellt mit 2 Problemen die noch bestehen:
1. die Codes von Hajo_Zi habe ich eingefügt, jedoch werden diese auf dem original Sheet angewendet und nicht auf dem neuen.
2. die Inhalte werden nur kopiert wenn es nur eine Sheet gibt, sobald mehrer angelegt sind, gehts nicht mehr. (Zum Testen mache ich immer bei Date +1 / +2 / etc. da es ja mehrere gleiche nicht geben kann.
https://www.herber.de/bbs/user/90552.xlsm

Anzeige
AW: Code erweitern
08.05.2014 11:23:38
EtoPHG
Hallo Christian,
Probier mal anstelle deines gesamten Codes:
Private Sub Wochenauswertung_Click()
Dim bCheckWSExists As Boolean
Dim sName As String
sName = Str(Date + 1)      ' Neuer Blattname
On Error Resume Next       ' Wird überprüft, ob er bereits vorkommt
bCheckWSExists = Not ThisWorkbook.Worksheets(sName) Is Nothing
On Error GoTo 0
If bCheckWSExists Then
MsgBox "Die Daten für " & sName & " wurden bereits kopiert!", vbExclamation, "Copy"
Else
With Worksheets.Add(Before:=Me)
.Name = sName
Worksheets("Auswertung").Range("A1:F32").Copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Range(.Cells(1, 7), .Cells(1, .Columns.Count)).EntireColumn.Hidden = True
.Range(.Cells(33, 1), .Cells(.Rows.Count, 1)).EntireRow.Hidden = True
End With
End If
Application.CutCopyMode = False
End Sub
Gruess Hansueli

Anzeige
AW: Code erweitern
08.05.2014 13:15:13
Christian
Das funktioniert perfekt.
Kannst du mir noch verraten, wie ich genau diesen einzelnen "neuen" Sheet gleich automatisch noch in eine Outlook-Email bekomme? (als Anhang oder als ob ich es per Copy&Paste machen würde).
Oder hast du für mich einen Extra-Code. Ich habe noch nichts passendes gefunden.... :-(

Und dann Blatt als Mail schicken:
08.05.2014 15:12:39
EtoPHG
Hallo Christian,
Gesamter Code ersetzen.
Konstante cMailReceiver anpassen, und los:
Option Explicit
Private Sub Wochenauswertung_Click()
Const cThisRange As String = "A1:F32"
Const cMailReceiver As String = "deine.email@adresse.de"
Dim bCheckWSExists As Boolean
Dim sName As String
Dim OutApp As Object
Dim OutMail As Object
sName = Str(Date + 1)      ' Neuer Blattname
On Error Resume Next       ' Wird überprüft, ob er bereits vorkommt
bCheckWSExists = Not ThisWorkbook.Worksheets(sName) Is Nothing
On Error GoTo 0
If bCheckWSExists Then
MsgBox "Die Daten für " & sName & " wurden bereits kopiert!", vbExclamation, "Copy"
Else
With Worksheets.Add(Before:=Me)
.Name = sName
Worksheets("Auswertung").Range(cThisRange).Copy
.Cells(1, 1).PasteSpecial Paste:=xlPasteAll
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
.Range(.Cells(1, 7), .Cells(1, .Columns.Count)).EntireColumn.Hidden = True
.Range(.Cells(33, 1), .Cells(.Rows.Count, 1)).EntireRow.Hidden = True
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = cMailReceiver
.Subject = "Neue Auswertung " & sName
.HTMLBody = RangetoHTML(Worksheets(Me.Index - 1).Range(cThisRange))
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End With
End If
Application.CutCopyMode = False
End Sub
' Source: http:// _
msdn.microsoft.com/en-us/library/ff519602(office.11).aspx
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close savechanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Gruess Hansueli

Anzeige
AW: Und dann Blatt als Mail schicken:
08.05.2014 15:33:16
Christian
Super, vielen Dank!!!!!!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige