Thema Datum  Von Nutzer Rating
Antwort
Rot Combibox
13.01.2021 08:00:57 Sabine
NotSolved
13.01.2021 09:36:33 Mase
NotSolved

Ansicht des Beitrags:
Von:
Sabine
Datum:
13.01.2021 08:00:57
Views:
65
Rating: Antwort:
  Ja
Thema:
Combibox

Hallo,
ich habe eine Frage zu meinem VBA Code (siehe code unten), komme selber nicht mehr weiter.

Es geht um die grafische Darstellung von Elementen für eine Spritzgussmaschine. Mit einer Combibox sollen mehrere Elemente aus einer Übersichtsdatei gewählt und so zusammengefügt werden, dass man in einem weiteren Tabellenblatt ein Bild der finalen individuell konfigurierten Schnecke bekommt.  Die gewünschten Elemente sollen (zum Beispiel) mit einer Combibox aus einer Liste der verfügbaren Elemente gewählt werden.

- Momentan kann man jedes Element nur einmal wählen:  ist es möglich die Bilder/Elemente mehrmals zu wählen? Also z.B

2x Förderelement - 1x Knetblock1 - 1x Förderelement -  2x Knetblock2 - 2x Förderlement etc. - die Reihenfolge der Elemente ist sehr wichtig und müsste wählbar sein. 

- in der Tabelle mit allen Informationen ist in Zeile 3 auch die Länge der jeweiligen Elemente gegeben. Kann man neben dem Bildern auch die Längen hinzufügen? Das heißt beim Auswählen vom "Förderelement" wird zusätzlich die länge "30mm" ausgewählt und im gleichen Tabellenblatt, wie die finale Grafik, eingefügt damit man beim zusammenfügen sieht ab wann man die maximal länge erreicht.


danke und viele Grüße

 

 

 

Option Explicit
 
 Dim TopPosBild As Double
 Dim LeftPosBild As Double
 
Public Sub Main()
     
     'Variablen
     Dim arr As Variant
     Dim objShape As Shape
     Dim i As Long, sArrElements As String
     
      ReDim arrElements(0 To 0)
     
     'Bildposition
     
     
     TopPosBild = Application.Worksheets("Test1").Range("$D$11").Top
     LeftPosBild = Application.Worksheets("Test1").Range("$D$11").Left + 10
     
     'Vorhandenes Bild löschen
     Application.Worksheets("Test1").Activate
 
     For Each objShape In ActiveSheet.Shapes
         If objShape.Top = TopPosBild Then
             objShape.Delete
         End If
     Next
        
    With Worksheets("test1").ListBox1
     
     If .ListIndex = -1 Then Exit Sub
     
     
     For i = 0 To .ListCount - 1
    
        '** Gewählte Einträge auslesen
        If .Selected(i) Then
             If .List(i) <> "" Then
                
                sArrElements = sArrElements & IIf(sArrElements = "", .List(i), "," & .List(i))
                
             End If
         End If
             
     Next
              
     If Len(sArrElements) = 0 Then Exit Sub
     
     arr = Split(sArrElements, ",")
     
     For i = LBound(arr) To UBound(arr)
       Call AddImage(getnames(arr(i)))
     Next
    End With
    
    Set objShape = Nothing
 
 End Sub
 
 
Public Sub AddImage(ByVal strElementgewaehlt As String)
 
  'Variablen
 
   Dim objShape As Shape
 
 
   Application.ScreenUpdating = False
   
    'Bild in Tabellenblatt "Tabelle" suchen und kopieren
 
    With Worksheets("Tabelle")
      .Activate
      .Shapes(strElementgewaehlt).Select: Selection.Copy 'statt Grafik 3, das Ergebnis der InputBox
    End With
 
    'Bild in Tabellenblatt "Konfiguration" einfügen
                 
     With Worksheets("Test1")
        
        .Activate
        .Range("$D$11").Select
        .Pictures.Paste
    
        'Bilder nebeneinander anordnen
    
         For Each objShape In .Shapes
    
             If objShape.TopLeftCell.Address = "$D$11" Then    '$D$11 ist die Zelle in der das Bild landen soll
    
                 objShape.Left = LeftPosBild
 
                 LeftPosBild = LeftPosBild + objShape.Width 'nächstes Bild rechts davon
    
             End If
    
         Next
         
    End With
    Application.ScreenUpdating = True
    
    Set objShape = Nothing
 End Sub
 
Function getnames(ByVal sName As String) As String
'wandelt die Bezeichnung in den Namen um
'sonst wird das element nicht in shapes() gefunden
    Dim objShape As Shape
    
    With Worksheets("Tabelle")
    
        For Each objShape In .Shapes
         
            Debug.Print objShape.Name & " : " & sName
              
            If CStr(objShape.TopLeftCell.Offset(-1).Value) = sName Then
               
               getnames = objShape.Name
               Exit For
            End If
        Next
    End With
    
    Set objShape = Nothing
End Function
 
 
 
Sub Laeng()
 
Call Main
 
 
End Sub

 

 
 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst genau und ausführlich
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
  • Bitte markieren Sie Ihre Anfrage als erledigt wenn Ihnen geholfen wurde
Thema: Name: Email:

 
 

Thema Datum  Von Nutzer Rating
Antwort
Rot Combibox
13.01.2021 08:00:57 Sabine
NotSolved
13.01.2021 09:36:33 Mase
NotSolved