An fcs (Franz) Druck Code änderung !
06.09.2016 14:18:55
Stefan
köntest du mir bitte deinen Code umschreiben, damit er in meiner Liste läuft ?
Ich stelle mich echt zu blöd an in der Sache ! Wollte ihn anpassen aber naja zeigt dann beim drucken was anderes an als es soll :-)).
ich hab ein Foto dabei.
Ab Name nach rechts bis Spalte AL und bis Zeile 500 runter.
Private wksData As Worksheet
Private Sub CommandButton2_Click()
'Auswahl drucken
Dim bolCheck As Boolean, intI As Integer
Dim Zeile As Long, Zeile_L As Long
Dim strLeft_1 As String
'Auswahl drucken
'Prüfen, ob Spalte(n) gewählt
With Me.ListBox2
For intI = 0 To .ListCount - 1
If .Selected(intI) = True Then
bolCheck = True
End If
Next
If bolCheck = False Then
MsgBox "Es wurde keine Spalte gewählt!", , "Prüfung Auswahl"
Exit Sub
End If
End With
'Prüfen, ob Namen gewählt
bolCheck = False
If Me.CheckBox1.Value = True Then
bolCheck = True
Else
With Me.ListBox1
For intI = 0 To .ListCount - 1
If .Selected(intI) = True Then
bolCheck = True
End If
Next
If bolCheck = False Then
MsgBox "Es wurde kein Name gewählt!", , "Prüfung Auswahl"
Exit Sub
End If
End With
End If
Application.ScreenUpdating = False
'Spalte(n) ein-/ausblenden
With Me.ListBox2
wksData.Columns(1).Hidden = True
For intI = 0 To .ListCount - 1
wksData.Columns(Val(.List(intI, 1))).Hidden = .Selected(intI) = False
Next
End With
'Zeilen mit Namen einblenden/ausblenden
If Me.CheckBox1.Value = True Then
wksData.Rows.Hidden = False
Else
With wksData
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Rows(2), .Rows(Zeile_L)).Hidden = True
End With
For Zeile = 2 To Zeile_L
If wksData.Cells(Zeile, 2).Text "" Then
strLeft_1 = Left(wksData.Cells(Zeile, 2).Text, 1)
With Me.ListBox1
For intI = 0 To .ListCount - 1
If .Selected(intI) = True Then
If strLeft_1 = .List(intI, 0) Then
wksData.Rows(Zeile).Hidden = False
Exit For
End If
End If
Next
End With
End If
Next
End If
Application.ScreenUpdating = True
Me.Hide
wksData.PrintPreview
' wksData.PrintOut '.PrintPreview
wksData.Columns.Hidden = False
wksData.Rows.Hidden = False
Me.Show
End Sub
Private Sub CommandButton3_Click()
'schließen
Unload Me
End Sub
Private Sub CommandButton4_Click()
'Reset Spalten
With Me.ListBox2
For intI = 0 To .ListCount - 1
.Selected(intI) = False
Next
.Selected(0) = True
End With
End Sub
Private Sub CommandButton5_Click()
'Reset Namen
With Me.ListBox1
For intI = 0 To .ListCount - 1
.Selected(intI) = False
Next
End With
End Sub
Private Sub CommandButton6_Click()
'Alle Spalten
With Me.ListBox2
For intI = 0 To .ListCount - 1
.Selected(intI) = True
Next
End With
End Sub
Private Sub ListBox1_Change()
Me.CheckBox1 = False
End Sub
Private Sub UserForm_Initialize()
Dim varList, intI As Integer
Set wksData = ActiveSheet
Dim objCol As New Collection
Dim bolRemove As Boolean
On Error GoTo Fehler
With wksData
varList = Application.WorksheetFunction.Transpose( _
.Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft).Offset(1, 0)))
'Spaltennummern zu Spaltentiteln eintragen
With Me.ListBox2
.List = varList
For intI = 0 To .ListCount - 1
.List(intI, 1) = 2 + intI
Next
End With
Me.ListBox2.Selected(0) = True
For Zeile = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row
With .Cells(Zeile, 2)
If Trim(.Text) "" Then
objCol.Add Left(Trim(.Text), 1), Left(Trim(.Text), 1)
End If
End With
Next
ReDim varList(1 To 29) As String
For intI = 1 To 26
varList(intI) = Chr(64 + intI)
Next
varList(27) = "Ä"
varList(28) = "Ö"
varList(29) = "Ü"
Me.ListBox1.List = varList
With Me.ListBox1
For intI = .ListCount - 1 To 0 Step -1
bolRemove = True
For Zeile = 1 To objCol.Count
If .List(intI, 0) = objCol(Zeile) Then
bolRemove = False
Exit For
End If
Next
If bolRemove = True Then
.RemoveItem (intI)
End If
Next
End With
Me.CheckBox1.Value = True
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'doppeltes Object in Collection
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & vbLf & .Description, vbOKOnly, _
"Fehler Makro: Userform-Initialize"
End Select
End With
End Sub
Gruß
Stefan