AW: Suche und automatischer Ausdruck
26.01.2012 16:32:18
fcs
Hallo Kalle,
ich hab die Prüfung der Eingabe auf nummerischen Wert in der Prozedur rausgenommen. D.h., es können jetzt beliebige Inhalte zum Suchen eingegeben werden.
Gruß
Franz
Option Explicit
Private varEingabe As Variant
Sub ZahlenSuchen()
Dim Zelle As Range, strErste As String
Dim Maxzahl As Double
Dim wks As Worksheet, wksDruck As Worksheet
Const lngSpalteLfdNr As Long = 1 'Spalte mit fortlaufender Nummer (A=1, B=2 usw.)
Set wks = Worksheets("Tabelle1")
Set wksDruck = Worksheets("Druck")
Eingabe:
varEingabe = InputBox(Prompt:="Zu suchende Zahl?", _
Title:="Zahlen suchen - fortlaufende Nummer eintragen", Default:=varEingabe)
If varEingabe = "" Then GoTo Beenden
'varEingabe in Spalte B suchen
Set Zelle = wks.Range("B:B").Find(What:=varEingabe, LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then
MsgBox "Eingegebene Zahl nicht gefunden"
GoTo Eingabe
Else
strErste = Zelle.Address
With wks
Do
'Prüfen, ob in Spalte A der Zeile bereits eine fortlaufende Nummer eingetragen ist
If IsEmpty(.Cells(Zelle.Row, lngSpalteLfdNr)) Then
'letzte (max.) Zahl YYYY0000000 in Spalte A berechnen
Maxzahl = Application.WorksheetFunction.Max(.Range("A:A"))
If Maxzahl = 0 Then
'noch keine fortlaufende Nummer eingetragen
Maxzahl = CDbl(Format(Date, "YYYY") & "0000001")
ElseIf Left(Format(Maxzahl, "00000000000"), 4) Format(Date, "YYYY") Then
'Neues Jahr hat begonnen
Maxzahl = CDbl(Format(Date, "YYYY") & "0000001")
Else
Maxzahl = Maxzahl + 1
End If
'neu Zahl YYYY0000000 in Spalte A (1) eintragen
.Cells(Zelle.Row, lngSpalteLfdNr) = Maxzahl
'Werte aus Spalten A bis C ins Druckblatt übertragen
wksDruck.Range("A1") = .Cells(Zelle.Row, 1)
wksDruck.Range("A2") = .Cells(Zelle.Row, 2)
wksDruck.Range("A3") = .Cells(Zelle.Row, 3)
'Barcode + Daten Drucken
wksDruck.PrintPreview 'Druckvorschau
' wksDruck.PrintOut 'direkt drucken auf aktiven Drucker
'Zelle in Spalte K selektieren
.Cells(Zelle.Row, 11).Select
Exit Do
Else
'Nächste Zeile mit gleicher Zahl suchen
Set Zelle = .Range("B:B").FindNext(after:=Zelle)
If Zelle.Address = strErste Then
MsgBox "Für Zahl " & varEingabe _
& " ist bereits eine fortlaufende Nummer eingetragen", _
vbInformation + vbOKOnly
GoTo Eingabe
End If
End If
Loop Until Zelle.Address = strErste
End With
End If
Beenden:
Set wks = Nothing: Set wksDruck = Nothing: Set Zelle = Nothing
End Sub