Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1536to1540
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 anpassen

Code anpassen
31.01.2017 17:27:44
Thommy
Hallo zusammen,
ich hoffe jemand kann mir hier helfen.
Ich würde gerne folgenden Code anpassen, so dass nicht neue Tabellenblätter erzeugt werden, sondern neue Arbeitsmappen (die aber danach auch wieder geschlossen werden).
Leider ging es nicht so einfach die Variable wksSheet als Workbook anstatt Worksheet zu definieren.
Der Code erzeugt aus einer Excel-Liste mit Kundennamen für jeden Kunden ein Sheet mit den einzelnen Positionen, speichert dieses ab und schreibt die Summe in eine Übersichtstabelle.
Das Problem ist nur, dass bei langen Kundennamen ein Fehler kommt, weil er das Sheet nicht erzeugen kann. Deshalb möchte ich das über separate Workbooks lösen.
Danke und Grüße
Thommy
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
varArrRange = Sheets("Vorbereitung_Rechnungen").Range("A1", Sheets("Vorbereitung_Rechnungen").Cells.SpecialCells(11)).Value
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
'For lngTMP = 1 To UBound(varArrRange, 1) ' no title
For lngTMP = 2 To UBound(varArrRange, 1) ' with title
If Not .Exists(varArrRange(lngTMP, 1)) Then
ReDim varArrItem(1 To UBound(varArrRange, 2), 1 To 1)
For lngTMP1 = 1 To UBound(varArrRange, 2)
varArrItem(lngTMP1, 1) = varArrRange(lngTMP, lngTMP1)
Next lngTMP1
.Add varArrRange(lngTMP, 1), varArrItem
Else
varArrItem = .Item(varArrRange(lngTMP, 1))
ReDim Preserve varArrItem(1 To UBound(varArrRange, 2), _
1 To UBound(varArrItem, 2) + 1)
For lngTMP1 = 1 To UBound(varArrRange, 2)
varArrItem(lngTMP1, UBound(varArrItem, 2)) = _
varArrRange(lngTMP, lngTMP1)
Next lngTMP1
.Item(varArrRange(lngTMP, 1)) = varArrItem
End If
Next lngTMP
For Each varItem In .keys
If Not IsEmpty(varItem) Then
On Error Resume Next
Set wksSheet = Sheets(varItem)
'On Error GoTo Fin
If wksSheet Is Nothing Then
Set wksSheet = Sheets.Add _
(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wksSheet.Name = varItem
' next two rows - with title
Sheets("Vorbereitung_Rechnungen").Rows(1).Copy wksSheet.Range("A1")
Application.CutCopyMode = True
End If
varArrItem = .Item(varItem)
' ...End(xlUp)(1) _ .... ' 1 = no title
wksSheet.Range("A" & Rows.Count).End(xlUp)(2) _
.Resize(UBound(varArrItem, 2), UBound(varArrItem, 1)).Value = _
Application.Transpose(varArrItem)
lngTMP2 = wksSheet.Range("A" & Rows.Count).End(xlUp).row
wksSheet.Range("D" & lngTMP2 + 1).Value = "Summe"
wksSheet.Range("E" & lngTMP2 + 1).Value = Application.WorksheetFunction.Sum(Range("G2:G" & lngTMP2))
wksSheet.Columns.AutoFit
With ThisWorkbook.Worksheets("Daten_Rechnungen")
lngTMP3 = .Range("A" & Rows.Count).End(xlUp).row

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code anpassen
01.02.2017 15:14:12
Max2
Hi,
da mir die Augen nach ein paar Zeilen brennen schreibe ich dir jetzt nur eine
Art der Lösung hier rein.
Damit kannst du ein Worksheet als Datei abspeichern.

Sub speichern()
Dim vDate As String
'Datum im Format: "JahrMonatTag" --> "20170127"
vDate = Format(Date, "YYYYMMDD")
Application.DisplayAlerts = False
Range("A2").Select
'Kopiere das Blatt "Dein Worksheet"
Sheets("Dein Worksheet").Select       

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige