Thema Datum  Von Nutzer Rating
Antwort
Rot Tabelle in neues Blatt kopieren und exprotieren als xlsm
02.11.2020 13:23:18 Eyyub
NotSolved
02.11.2020 13:24:51 Eyyub
NotSolved
02.11.2020 13:42:11 Eyyub
Solved

Ansicht des Beitrags:
Von:
Eyyub
Datum:
02.11.2020 13:23:18
Views:
947
Rating: Antwort:
  Ja
Thema:
Tabelle in neues Blatt kopieren und exprotieren als xlsm

Hallo alle Zusammen,

 

Ich habe aktuell ein Projekt, in dem ich eine Tabelle in ein neues Arbeitsblatt kopiere und exportieren möchte als eigene Excel-Datei.

Ich habe auch schon ein Code geschrieben, welcher aber die komplette Arbeitsmappe, in der das Makro läuft, speichert. Hat jemand eine Lösung?

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
Option Explicit
 
Sub anlagenEinzelnExcel()
 
'---Spalten mit RG-Nummer-Einträgen zählen---
 
Dim RG_Nr As Integer
Dim countRow As Double
Dim i As Double
Dim cellnumeric As Boolean
Dim RG_Column As Long ' Spalte, in der die RG Nummer steht
Dim rgWs As Worksheet
Set rgWs = ThisWorkbook.Worksheets("RG-Anlage")
Dim Blatt As Worksheet
 
For Each Blatt In ThisWorkbook.Worksheets
    If Blatt.Name = "AnlagenTab" Then
        GoTo Weiter
    End If
Next Blatt
 
Weiter:
Worksheets("RG-Anlage").Activate
 
i = 7
countRow = 7
RG_Column = Range(ActiveSheet.PageSetup.PrintArea).Columns.Count + 2
Cells(countRow, RG_Column).Activate
 
 
Do Until ActiveCell.Value = 0
    Cells(countRow, RG_Column).Activate
    RG_Nr = ActiveCell.Value
    countRow = countRow + 1
Loop
 
countRow = countRow - 8
 
'---Anlagen trennen durch RG-Nummern und exportieren auf Word-Datei---
 
Dim currentColumn As Double 'enthält die aktuelle SpaltenANzahl
Dim pastColumnValue As Integer 'Enthält den vorigen Spaltenwert, wird verwendet um Druckbereich festzulegen
Dim countRange As Integer 'gibt die Spaltenanzahl der Anlage mit der aktuellen RG-Nummer an
Dim aktuelleSpaltenZahl As Integer 'Enthält die Spaltenanzahl, die aktuell zu markieren/drucken ist
Dim j As Double 'Zählervariable für Schleife
Dim strPrintArea As String 'String mit dem Druckbereich
Dim druckZeile As String 'Zeile der Anlage, ab der gedruckt werden soll
 
countRange = 0
currentColumn = 7
Cells(currentColumn, RG_Column).Activate
RG_Nr = ActiveCell.Value
 
'Druck-Schleife
For j = 0 To countRow - 1
    Worksheets("RG-Anlage").Activate
    Worksheets("RG-Anlage").Cells(currentColumn, RG_Column).Activate 'Zeigt aktuell angewählte Zelle an
     
    If ActiveCell.Value > RG_Nr Then
        'Druckbereich auswählen - Start
        Call CreateExcelAnlagen(Worksheets("RG-Anlage").Range(Cells(currentColumn - countRange + 1, 2), Cells(currentColumn - 1, RG_Column - 1)), RG_Nr, KundenNr)
        'ActiveSheet.range(Cells(currentColumn - countRange, 2), Cells(currentColumn - 1, RG_Column - 1)).ExportAsFixedFormat xlTypePDF, Filename:=ThisWorkbook.Path & "\Anlage " & RG_Nr & ".pdf"
        'Druckbereich auswählen - Ende
        RG_Nr = RG_Nr + 1
        currentColumn = currentColumn + 1
        countRange = 1
    ElseIf ActiveCell.Value < RG_Nr Then
        Exit For
    ElseIf ActiveCell.Value = RG_Nr Then
        currentColumn = currentColumn + 1
        countRange = countRange + 1
    End If
Next j
''''''''''MsgBox (rg_Nr & " ist " & countRange & " Spalten lang")
 
'Druckbereich auswählen - Start
Call CreateExcelAnlagen(Worksheets("RG-Anlage").Range(Cells(currentColumn - countRange + 1, 2), Cells(currentColumn - 1, RG_Column - 1)), RG_Nr, KundenNr)
'Druckbereich auswählen - Ende
Worksheets("RG-Anlage").Activate
 
End Sub
 
Private Function CreateExcelAnlagen(rRange As Range, RGNr As Integer, KundenNr As Long)
Dim tabWs As Worksheet
Dim strPfad As Variant
strPfad = ThisWorkbook.Path & "\" & "anlagen_excel"
 
ThisWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
Worksheets(Sheets.Count).Name = "AnlagenTab"
 
Set tabWs = ThisWorkbook.Worksheets("AnlagenTab")
 
    With tabWs
        .Activate
         
        .Cells(2, 1).Value = "Kundennummer: " & KundenNr
        .Cells(3, 1).Value = "Rechnungsnummer: " & Year(Date) & "-" & RGNr
        .Cells(4, 1).Value = "Datum: " & Date
        Worksheets("RG-Anlage").Activate
        Worksheets("RG-Anlage").Range(Cells(6, 2), Cells(6, Range(ActiveSheet.PageSetup.PrintArea).Columns.Count + 1)).Copy
        .Activate
        .Cells(6, 1).PasteSpecial Paste:=xlPasteColumnWidths
        .Cells(6, 1).PasteSpecial Paste:=xlPasteValues
        rRange.Copy
        .Cells(7, 1).PasteSpecial Paste:=xlPasteColumnWidths, SkipBlanks:=True
        .Cells(7, 1).PasteSpecial Paste:=xlFormats
        .Cells(7, 1).PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
    End With
 
    'Überschrift Anlage zu Rechnung
    With tabWs.Cells(1, 1)
        .Value = "Anlage zu Rechnung"
        .Font.Size = 12
        .Font.Bold = True
    End With
 
    'Adresse einfügen
    With tabWs.Cells(1, tabWs.UsedRange.SpecialCells(xlCellTypeLastCell).Column)
        .Value = "WATERcontrol AG" & vbCrLf & "Alter Flughafen 16 B" & vbCrLf & "30179 Hannover"
        .EntireColumn.AutoFit
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
 
    'Erste Zeile formatieren
    With tabWs.Cells(1, 1).EntireRow
        .Font.Bold = True
        .VerticalAlignment = xlCenter
    End With
 
    'Linien erzeugen
    With Cells(6, 1).CurrentRegion
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
        .BorderAround Weight:=xlThick
    End With
 
    'Überschriften in PDF Fett schreiben
    With Cells(6, 1).EntireRow
        .Font.Bold = True
        .WrapText = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
 
    'Druckeinstellungen Ausrichtungen etc..
    With tabWs.PageSetup
        .Zoom = False
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
     
    If Dir(strPfad, vbDirectory) <> "" Then
    Else
        MkDir strPfad
    End If
     
    tabWs.SaveAs Filename:=strPfad & "\" & RGr, FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = False
    Worksheets("AnlagenTab").Delete
    Application.DisplayAlerts = True
 
End Function
 
 
Private Function KundenNr() As Long
Dim i As Integer
Dim KDNr As Long
Dim geWs As Worksheet 'Arbeitsblatt "gesamtexport"
Set geWs = ThisWorkbook.Worksheets("gesamtexport")
 
For i = 1 To geWs.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    If geWs.Cells(1, i) = "KDNummer" Then
        KDNr = geWs.Cells(2, i).Value
        Exit For
    End If
Next i
 
KundenNr = KDNr
 
End Function

 

 

Grüße,

Eyyub


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:



  • 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 Tabelle in neues Blatt kopieren und exprotieren als xlsm
02.11.2020 13:23:18 Eyyub
NotSolved
02.11.2020 13:24:51 Eyyub
NotSolved
02.11.2020 13:42:11 Eyyub
Solved