Textboxen kopieren Code verfeinern
15.12.2007 20:14:32
Fred
Ich habe hier einen Code gefunden, der für mich fast perfekt ist.
Mit ihm kann ich den inhalt aller Textboxen in ein neues Blatt schreiben.Leider copiert er auch alle anderen ole Objekte wie Buttons,Comboboxen und ähnliches auch mit.
Kann mir jemand helfen ihn so umzuschreiben,das er nur die Textboxen kopiert
Vielen Dank für Eure hilfe
anbei mal der Code
Private Sub CommandButton20_Click()
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Fehler"
Dim Blatt As Long
For Blatt = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Blatt).Unprotect Password:="Bertelsmann1969"
Next Blatt
Dim Obj As OLEObject
Dim shQuelle As Worksheet
Dim shZiel As Worksheet
Sheets("Schichtübergabe").Select
Set shQuelle = Sheets("Schichtübergabe")
With ActiveSheet
Debug.Print .OLEObjects("Textbox1").Object.Value
Set shZiel = Sheets("Fehler")
Sheets("Fehler").Cells(3, 1).Resize(1000).EntireRow.ClearContents
For Each Obj In shQuelle.OLEObjects
If Obj.OLEType = 2 Then
With shZiel.Cells(65536, 1).End(xlUp).Offset(1, 0)
.Value = Obj.Name
On Error GoTo DispFehler
Application.DisplayAlerts = False
.Offset(0, 1) = Replace(Obj.Object.Value, Chr(13), "")
DispFehler:
Application.DisplayAlerts = True
End With
End If
Next
Sheets("Fehler").Select
Sheets("Fehler").Columns("B:B").Select
Selection.AutoFormat Format:=xlRangeAutoFormatList1, Number:=True, Font:= _
True, Alignment:=True, Border:=True, Pattern:=True, Width:=True
Selection.Rows.AutoFit
Sheets("Fehler").Columns("B:B").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Arial"
.FontStyle = "Fett"
.Size = 14
End With
For Blatt = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(Blatt).Protect Password:="Bertelsmann1969", DrawingObjects:=True, _
Contents:=True, Scenarios:=True
ActiveSheet.EnableSelection = xlUnlockedCells
Next Blatt
End With
End Sub