AW: Freie Zelle suchen und füllen
06.09.2017 15:16:45
Peter
Hallo,
anbei deine Mappe mit anderem Code.
Ich habe mir auch die Freiheit genommen, die UF Farbig zu machen.
Es sah im Code danach aus als ob du dass auch noch machen möchtest später,
vielleicht hift dir ja der Code im UserForm_Initialize event was.
Der neue Code, sucht nur einmal wnr im Bereich und ergänzt bzw. fügt auch nur einmal hinzu
Einfach mal ausprobieren und durchlesen.
Wenn du was im Code nicht verstehst, dann sag bescheid.
Hier Mappe: https://www.herber.de/bbs/user/116042.xlsm
Hier nur Code wer nichts runterladen will:
Option Explicit
Private worksheet_ As Worksheet
Private Const myRed As Long = &HA41C37
Private Const myGreen As Long = &H1CA41C
Private Const myWhite As Long = &HFFFFFF
Private Sub UserForm_Initialize()
Dim ctl As Control
Dim tb As MSForms.TextBox
Dim lbl As MSForms.Label
Me.BackColor = myGreen
For Each ctl In Me.Controls
If TypeOf ctl Is MSForms.Label Then
Set lbl = ctl
lbl.BackColor = myRed
lbl.ForeColor = myWhite
ElseIf TypeOf ctl Is MSForms.TextBox Then
Set tb = ctl
tb.BackColor = myGreen
tb.ForeColor = myWhite
End If
Next ctl
End Sub
Private Sub CommandButton1_Click()
ChangeSheet
End Sub
'// Sucht wnr, falls vorhanden, wird die Zelle links neben wnr verändert
'// falls nicht gefunden, wird wnr hinzugefügt
Private Sub ChangeSheet()
Dim array_() As Variant, cell_ As Variant
Dim thisRow As Long, thisColumn As Long
Dim rowArray() As Long, wnrRow As Long
Dim amount As Variant, wnr As String
wnr = TextBox2.Value
amount = TextBox3.Value
array_ = SplitValues(ComboBox5.Value)
If IsEmpty(array_) Then Exit Sub
Set worksheet_ = ThisWorkbook.Sheets("Lagerverwaltung")
ReDim rowArray(1 To 3): rowArray(1) = 6: rowArray(2) = 4: rowArray(3) = 2
'//Alt
thisRow = DefineRange(array_(1))
thisColumn = rowArray(array_(0))
wnrRow = FindWNR(wnr, thisRow, thisColumn)
If wnrRow 0 Then
ChangeOffsetCell wnrRow, thisColumn + 1, amount
Else
If AddWNR(thisRow, thisColumn, wnr) = False Then MsgBox "Lagerplatz ist voll!"
End If
Erase array_
array_ = SplitValues(ComboBox6.Value)
If IsEmpty(array_) Then Exit Sub
'//Neu
thisRow = DefineRange(array_(1))
thisColumn = rowArray(array_(0))
wnrRow = FindWNR(wnr, thisRow, thisColumn)
If wnrRow 0 Then
ChangeOffsetCell wnrRow, thisColumn + 1, amount
Else
If AddWNR(thisRow, thisColumn, wnr) = False Then MsgBox "Lagerplatz ist voll!"
End If
End Sub
'// Teile den übergebenden Wert auf und speichere die teile in einem Array
Private Function SplitValues(ByVal splitThis As String) As Variant
Dim array_ As Variant
Dim i As Long
ReDim array_(1)
For i = 1 To Len(splitThis)
If IsNumeric(Mid(splitThis, i, 1)) Then
array_(0) = array_(0) & Mid(splitThis, i, 1)
Else
array_(1) = array_(1) & Mid(splitThis, i, 1)
End If
Next i
SplitValues = array_
End Function
'// Ermittle die Zeile des gesuchten Begriffes
Private Function DefineRange(ByVal findMe As String) As Long
Dim rng As Range, c
With worksheet_
Set rng = .Range(.Cells(3, 1), .Cells(44, 1))
Set c = rng.Find(findMe, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then DefineRange = c.Row
End With
Set c = Nothing
Set rng = Nothing
End Function
'// Finde Wnr in Bereich
Private Function FindWNR(ByVal wnr As String, ByVal whereRow As Long, ByVal whereColumn As Long) _
As Long
Dim rng As Range, c
With worksheet_
Set rng = .Range(.Cells(whereRow, whereColumn), .Cells(whereRow + 3, whereColumn))
Set c = rng.Find(wnr, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then FindWNR = c.Row
End With
Set c = Nothing
Set rng = Nothing
End Function
'// Ändere die Zelle links neben Wnr
Private Sub ChangeOffsetCell(ByVal whereRow As Long, ByVal whereColumn As Long, ByVal amount As _
Variant)
Dim cell_
Set cell_ = worksheet_.Cells(whereRow, whereColumn)
If cell_.Value > 0 Then
cell_.Value = cell_.Value - amount
ElseIf cell_.Value = 0 Then
cell_.ClearContents
ElseIf cell_.Value