VBA Sheet kopieren, einfügen, füllen

19/03/2010 - 09:56 von Der_Soern | Report spam
OK Ich hab das Problem hier schon lànger.
Komme zwar Hàpchen-weise weiter (Danke Andreas), aber es ist grad
festgefahren.

In meinem Code làuft eine Prozudur über ein Tabellenblatt "Download" und
liest die Überschriftenzeile ein die unter "Einstellungen" eingetragen ist.
Das muss so sein weil sich der Download stetig veràndert.
Dann öffnet sich eine Userform und bietet die Überschriften mit Checkboxes an.

Jetzt mein Problem:
Ich versuche jetze die Angeklickten in ein neues Blatt zu übernehmen. Das
neue Blatt soll "Report1" heißen und vor die bestehenden gesetzt werden.
Außerdem soll das Blatt die selben Commandbuttons haben wie das Blatt
"Download". Wenn ich die Userform nochmal ausführe soll das dann erzeugte
Blatt "Report2" heißen. Allerdings soll die Nummernvergabe abhàngig von der
Anzahl der Tabellenblàtter sein. Wenn also noch kein Report da ist sind in
meiner Mappe zwei Blàtter.

Zweites Problem:
Die Userform führt nur korrekt aus wenn ich die erste Checkbox aktiviere.
Sonst bekomme ich einen Fehler. Da finde ich den Grund nicht.

Danach funktioniert es soweit.
Die überflüssigen drei Zeilen über den Überschriften werden gelöscht, die
Werte in der Spalte werden vom "Download" übernommen und in den "Report"
geschrieben und ein Autofilter und fit wird aufgesetzt.

Wenn mir Jemand helfen kann wàre super.

Hier mal der betreffende Quellcode:
Option Explicit

'Höhe des Userformtitels
Private Const Titel = 19
'Abstand zwischen den Elementen
Private Const Rand = 3

'Events für die CommandButtons
Private WithEvents Ok As MSForms.CommandButton
Private WithEvents Abort As MSForms.CommandButton

Sub Bereich_Einlesen(ByRef Arr(), Bereich As Range)
'Liest die Werte der nicht leeren Zellen in Bereich ein
Dim I As Long, R As Range
ReDim Arr(1 To Bereich.Count)
For Each R In Bereich
If Not IsEmpty(R) Then
I = I + 1
Arr(I) = R
End If
Next
ReDim Preserve Arr(1 To I)
End Sub

Private Sub UserForm_Initialize()
Dim I As Long
Dim C As Control
Dim X As Single, Y As Single, W As Single, H As Single

Dim Data(), Anzahl As Integer
Dim Spalten As Integer, Zeilen As Integer
Dim MaxWidth As Single, MaxHeight As Single

Dim US As Integer

'Zeilennummer einlesen um Ueberschriftenzeile zu finden
US = Worksheets("Einstellungen").Cells(4, 6)
'Überschriften einlesen
Bereich_Einlesen Data, _
Intersect(Rows(US), ActiveSheet.UsedRange)

'Verteilung berechnen
Anzahl = UBound(Data)
Spalten = Sqr(Anzahl / 2)
Zeilen = WorksheetFunction.RoundUp(Anzahl / Spalten, 0)

'Position des ersten Controls
X = Rand
Y = Rand
For I = 1 To Anzahl
'Checkbox hinzufügen
Set C = Me.Controls.Add("Forms.CheckBox.1")
'Automatische Größenànderung erlauben
C.AutoSize = True
'Breite setzen, sonst wird's ggf. mehrzeilig
C.Width = 9999
'Namen vergeben
C.Caption = Data(I)
'Markieren (siehe OK_Click)
C.Tag = "CheckBox"
'Positionieren
C.Left = X
C.Top = Y
'Vert. Position nàchstes Control
Y = Y + C.Height + Rand
'Max. Breite der Control in dieser Spalte bestimmen
W = WorksheetFunction.Max(W, C.Width)
'Max. Höhe bestimmen
H = WorksheetFunction.Max(H, C.Top + C.Height)

If I Mod Zeilen = 0 Then
'Nàchste Spalte
X = X + W + Rand
Y = Rand
W = 0
End If
Next
'Hor. Position letztes Element
X = X + W

'Ok-Button hinzufügen
Set C = Me.Controls.Add("Forms.CommandButton.1")
C.Default = True
C.Caption = "Ok"
C.Top = H + Rand
C.Left = Rand
'Event-Sub aktivieren
Set Ok = C

'Hor. Position Abbruch-Button berechnen
I = C.Left + C.Width + Rand

'Abbruch-Button hinzufügen
Set C = Me.Controls.Add("Forms.CommandButton.1")
C.Cancel = True
C.Caption = "Abbruch"
C.Top = H + Rand
C.Left = I
Set Abort = C

'Hor.Ausdehnung prüfen, damit die CommandButtons zu sehen sind
If C.Left + C.Width + Rand > X Then _
X = C.Left + C.Width + Rand

'Vert. Position nach Abbruch-Button berechnen
H = C.Top + C.Height

With Me
'Größe der UserForm setzen
.Height = H + Rand + Titel
.Width = X + Rand

'Maximale Größe = Hàlfte Excel-Fenster
MaxWidth = Application.Width / 2
MaxHeight = Application.Height / 2

If .Height > MaxHeight Or .Width > MaxWidth Then
'Scrollbalken hinzufügen
.ScrollBars = fmScrollBarsBoth
'Scrollen bis letztes Element kompl. sichtbar
.ScrollHeight = .Height
.ScrollWidth = .Width
'Größe begrenzen
.Height = MaxHeight
.Width = MaxWidth
End If
End With
End Sub

Private Sub Abort_Click()
'UserForm schließen
Unload Me
End Sub

Private Sub Ok_Click()
Dim C As Control, X As Integer
Dim WS As Worksheet
Dim Count As Integer
Dim US As Integer

'Zeilennummer einlesen um Ueberschriftenzeile zu finden
US = Worksheets("Einstellungen").Cells(4, 6)


'Teste alle Elemente
For Each C In Controls
'Ist es ein "markiertes"?
If C.Tag = "CheckBox" Then
'Angehakt?
If C.Value Then
'Neues Blatt erzeugen
If WS Is Nothing Then Set WS = Worksheets.Add
'Dann Wert in Zelle
X = X + 1
WS.Cells(1, X) = C.Caption
End If
'Counter fuer Namensgebung
Count = Worksheets.Count - 2
'Umbenennen der Blattes
WS.Name = "Report" & Count
End If
Next


'***********************


'Kopieren der Spalten
Dim V As Long, B As Range

'Die neue Tabelle
Sheets("Report" & Count).Select
'Die alte Tabelle
With Sheets("Download")
'Durchlauf alle Spalten der neuen Tabelle
For V = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
'Zelle leer?
If Not IsEmpty(Cells(1, V)) Then
'Nein, suche in Zeile US der alten Tabelle
Set B = .Rows(US).Find(Cells(1, V), LookAt:=xlWhole)
'Gefunden?
If Not B Is Nothing Then
'Ja, Spalte kopieren
B.EntireColumn.Copy Cells(1, V)
End If
End If
Next
End With
'Löschen der nicht benötigten Zellen
Cells(US - 1, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Delete Shift:=xlUp

Cells.Select
'Automatisches Filtern der Ausgabe
Cells.AutoFilter
'Zellenbreite anpassen
Cells.EntireColumn.AutoFit
'Zeile 1 auswaehlen
Cells(1, 1).Select

'UserForm schließen
Unload Me

End Sub


Andreas hat mir zur Namensgebung der Reports noch das hier geschickt, Ich
weiß aber nicht wie ich es einbauen kann.
Sub Test()
Dim WS As Worksheet, I As Integer
For I = 1 To 10
Set WS = Sheets.Add
WS.Name = NewSheetName("Report")
Next
End Sub

Function ValidSheetName(ByVal SheetName As String) As String
'Entfernt ungültige Zeichen aus Sheetname
Const InvalidChars = ":\/?*[]"
Dim I As Integer
For I = 1 To Len(InvalidChars)
SheetName = Replace(SheetName, Mid(InvalidChars, I, 1), "")
Next
ValidSheetName = Mid(SheetName, 1, 31)
End Function

Function NewSheetName(ByVal SheetName As String) As String
'Gibt einen nicht existierenden Tabellenblattnamen zurück _
der mit SheetName beginnt
Dim I As Integer, NewName As String, SheetExt As String
SheetName = ValidSheetName(SheetName)
NewName = SheetName
If SheetExists(SheetName) Then
I = 0
Do
I = I + 1
SheetExt = " (" & I & ")"
If Len(SheetName) + Len(SheetExt) > 31 Then SheetName = _
Mid(SheetName, 1, 31 - Len(SheetExt))
NewName = SheetName & SheetExt
Loop Until Not SheetExists(NewName)
End If
NewSheetName = NewName
End Function

Function SheetExists(ByVal SheetName As String, Optional WB As _
Workbook = Nothing) As Boolean
'Prüft ob das Tabellenblatt SheetName existiert
Dim S As Worksheet
If WB Is Nothing Then Set WB = ActiveWorkbook
On Error GoTo ExitPoint
Set S = WB.Sheets(SheetName)
SheetExists = True
ExitPoint:
End Function

Wenn mir da Jemand helfen kann wàre das super. Ich werde mich auch
erkenntlich zeigen.

Gruß
 

Lesen sie die antworten

#1 Peter Schleif
19/03/2010 - 16:49 | Warnen spam
Der_Soern schrieb am 19.Mrz.2010 09:56 Uhr:

Wenn mir Jemand helfen kann wàre super.



Kannst Du mal die Mappe irgendwo uploaden und verlinken?!

Peter

Ähnliche fragen