TRANSPOSE
05.05.2014 18:14:05
Erich
Hi,
das Problem entsteht durch die Verwendung von Application.Transpose im Code der UF.
Zum Hintergrund siehe z. B. mal hier:
https://www.herber.de/forum/archiv/1220to1224/t1222028.htm
https://www.herber.de/forum/archiv/1212to1216/t1215396.htm
Der Code schien mir teilweise unnötig kompliziert und lang. Versuche mal
Option Explicit
Private Declare Sub keybd_event Lib "User32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Dim Bol2 As Boolean
Dim multisearch As Boolean
Private arrTmp As Variant
Private Sub CommandButton3_Click()
ClearAll
End Sub
Private Sub CommandButton4_Click()
Unload Me
End Sub
Private Sub CommandButton5_Click() 'Button liegt auf der Userform
Dim Alle_Drucker
Dim wshNetwork
Dim i As Integer
Dim Drucker
Set wshNetwork = CreateObject("WScript.Network")
Set Alle_Drucker = wshNetwork.EnumPrinterConnections
keybd_event &H2C, 1, 0, 0 'Screenshot der Userform erstellen
Worksheets.Add before:=Worksheets(1) 'Temporäres Blatt einfügen
With Application
Drucker = .ActivePrinter 'ActivePrinter merken
.Wait (Now + TimeValue("0:00:01"))
'PDF-Drucker suchen
For i = 1 To Alle_Drucker.Count Step 2
If LCase(Alle_Drucker.Item(i)) Like "*pdf*" Then
wshNetwork.SetDefaultPrinter Alle_Drucker.Item(i)
Exit For
End If
Next
.DisplayAlerts = False
With Worksheets(1)
.Paste 'Screenshot einfügen
With .PageSetup
.Orientation = xlLandscape
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
.PrintOut 'Als PDF Drucken
.Delete 'Temporäres Blatt löschen
End With
.ActivePrinter = Drucker 'Alten Drucker wieder als Standard setzen
.DisplayAlerts = True
End With
Set wshNetwork = Nothing
End Sub
Sub ClearAll()
TextBox9.Text = ""
TextBox10.Text = ""
TextBox11.Text = ""
TextBox12.Text = ""
TextBox13.Text = ""
TextBox14.Text = ""
TextBox15.Text = ""
Label26 = ""
ListBox1.Clear
UserForm_Activate
End Sub
Private Sub TextBox9_Change()
Array_Prüfen TextBox9, 1
End Sub
Private Sub TextBox10_Change()
Array_Prüfen TextBox10, 2
End Sub
Private Sub TextBox11_Change()
Array_Prüfen TextBox11, 3
End Sub
Private Sub TextBox12_Change()
Array_Prüfen TextBox12, 4
End Sub
Private Sub TextBox13_Change()
Array_Prüfen TextBox13, 5
End Sub
Private Sub TextBox14_Change()
Array_Prüfen TextBox14, 6
End Sub
Private Sub TextBox15_Change()
Array_Prüfen TextBox15, 7
End Sub
Private Sub UserForm_Activate()
Dim letzte As Long
letzte = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
arrTmp = Worksheets(1).Range("A3:G" & letzte)
TextBox1.SetFocus
End Sub
Private Sub Array_Prüfen(ByVal txt As control, ByVal Spalte As Integer)
Dim i As Long, j As Long, r As Long, lngA As Long
Dim arrT() As Variant
If Len(txt.Text) > 0 Then
For i = LBound(arrTmp) To UBound(arrTmp)
If LCase(arrTmp(i, Spalte)) Like "*" & LCase(txt.Text) & "*" Then lngA = lngA + 1
Next i
If lngA > 0 Then
ReDim arrT(1 To lngA, 0 To 6)
For i = LBound(arrTmp) To UBound(arrTmp)
If LCase(arrTmp(i, Spalte)) Like "*" & LCase(txt.Text) & "*" Then
r = r + 1
For j = 0 To 6
arrT(r, j) = arrTmp(i, j + 1)
Next j
End If
Next i
ListBox1.List = arrT
Label26.Caption = ListBox1.ListCount & " Datensätze gefunden"
Else
MsgBox "Keine passenden Daten zu den Kriterien gefunden !"
txt.Text = ""
txt.SetFocus
End If
End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Bol2 = False
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich