In Teilprobleme zerlegen und runterproggen:
Falls du die Referenz auf einen Bereich als Rückgabe brauchst, siehst du das am Beispiel von MaterialExists.
Option Explicit
Sub Test()
'neuer Material-Eintrag
Call AddMaterial(Material:="TEST_XYZ", Serials:="TEST_SN_XYZ")
Stop
Call AddMaterial(Material:="TEST_0123456789", Serials:=Array("TEST_001", "TEST_002", "TEST_003"))
Stop
'Material-Eintrag zu bereits vorhandenen Material (=Anfügen)
Call AddMaterial(Material:="6MF10130CJ380AA0BB", Serials:="TEST_SN_6MF10130CJ380AA0BB")
Stop
Call AddMaterial(Material:="6MF10130CF510AA0CC", Serials:=Array("TEST_SN_6MF11112AJ200AA0GG_1", "TEST_SN_6MF11112AJ200AA0GG_2"))
Stop
End Sub
'////////////////////////////////
'// Hilfsfunktion:
'// Seriennummern für (ggf. neues) Material eintragen
Public Function AddMaterial(Material As String, Serials As Variant) As Boolean
Dim rngMaterial As Excel.Range
Dim vntSerials As Variant
Dim vntSerial As Variant
Dim nSerials As Long
If (VarType(Serials) And vbArray) = vbArray Then
nSerials = UBound(Serials) - LBound(Serials) + 1
vntSerials = Serials
Else
nSerials = 1
vntSerials = Array(Serials)
End If
If MaterialExists(Material, rngMaterial) Then
'unterhalb des letzten Eintrags Platz für neue Serials schaffen
Set rngMaterial = rngMaterial.Offset(rngMaterial.Rows.Count - 1).Cells(1)
Call rngMaterial.Offset(1).Resize(nSerials).EntireRow.Insert(xlShiftDown)
'erste Zelle für neue Einträge referenzieren
Set rngMaterial = rngMaterial.Offset(1)
Else
Set rngMaterial = GetMaterials
If Not rngMaterial Is Nothing Then
'erste Zelle für neue Einträge referenzieren
Set rngMaterial = rngMaterial.Offset(rngMaterial.Rows.Count).Cells(1)
Else
Set rngMaterial = GetMaterialHeader
If rngMaterial Is Nothing Then
Call MsgBox("Material-Spalte wurde nicht gefunden.", vbCritical, "AddMaterial ist fehgeschlagen")
Exit Function
End If
Set rngMaterial = rngMaterial.Offset(1)
End If
End If
'Material eintragen
rngMaterial.Resize(nSerials).Value = Material
'Serials eintragen
For Each vntSerial In vntSerials
rngMaterial.Offset(0, 1).Value = vntSerial
Set rngMaterial = rngMaterial.Offset(1)
Next
AddMaterial = True
End Function
'////////////////////////////////
'// Hilfsfunktion:
'// sieht nach ob Einträge zu einem Material existieren
'// liefert optional den Bereich mit dem gefundenen Material
Public Function MaterialExists(Material As String, Optional ByRef MaterialRange As Excel.Range) As Boolean
Dim rngMaterial As Excel.Range
Dim rngMaterials As Excel.Range
Dim n As Long
Set rngMaterials = GetMaterials
If rngMaterials Is Nothing Then Exit Function
Set rngMaterial = rngMaterials.Find(Material, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False)
If rngMaterial Is Nothing Then Exit Function
'weitere Treffer direkt darunter?
n = 1
Do While rngMaterial.Offset(n).Value = rngMaterial.Value
n = n + 1
Loop
Set MaterialRange = rngMaterial.Resize(n)
MaterialExists = True
End Function
'////////////////////////////////
'// Hilfsfunktion:
'// liefert den Bereich der Materialen
Private Function GetMaterials() As Excel.Range
Dim rngHeader As Excel.Range
Dim rngData As Excel.Range
With ThisWorkbook.Worksheets("Sample")
Set rngHeader = GetMaterialHeader
If rngHeader Is Nothing Then Exit Function
Set rngData = .Range(rngHeader.Offset(1), .Cells(.Rows.Count, rngHeader.Column).End(xlUp))
If rngData.Row < rngHeader.Offset(1).Row Then Exit Function
End With
Set GetMaterials = rngData
End Function
'////////////////////////////////
'// Hilfsfunktion:
'// liefert die Zelle mit dem Inhalt "Material"
Private Function GetMaterialHeader() As Excel.Range
On Error GoTo ErrHandler
Dim rngHeader As Excel.Range
With ThisWorkbook.Worksheets("Sample")
Set rngHeader = .Columns("A").Find("Material", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False)
If rngHeader Is Nothing Then Exit Function
End With
Set GetMaterialHeader = rngHeader
Exit Function
ErrHandler:
Set GetMaterialHeader = Nothing
End Function
|