VBA Datenbankauszug Ersatzteilliste

Forumthread: VBA Datenbankauszug Ersatzteilliste

16.04.2019 20:16:16

Tarek

Hallo Leute,
ich habe ein Problem mit dem Erstellen eines Datenbankauszugs.
Die Ersatzteilliste soll für Pumpen Ersatzteile anzeigen.
Es wird nach 6 Variablen gefilter, davon sind die ersten beiden am wichtigsten, sie stehen für die Baureihe und die Baugröße (Bsp. SLH-4G 3000)
Jede einzelne Pumpe stellt ein Tabellenblatt da, welche mit Datensätzen aus einem ERP-Programm von mir exportiert wurden.
Ich habe bereits eine UserForm erstellt, diese mit Comboboxen gefüllt.
Nun folgendes Problem: Ich möchte das beim Drücken des Buttons "Ausführen" folgendes Abläuft
Wenn Combobox1 = SLH-4S und Combobox2 = 2000, dann soll aus dem Tabellenblatt SLH-4S 2000 in der Spalte F:F die eingetragenen Werkstoff in Kombination aus denen, die in der UserForm eingetragen sind, auf dem Tabellenblatt 2 ausgegeben werden.
Der Sinn dahinter ist, dass man einfach in der UserForm die Werkstoffe der Pumpe einträgt und die Ersatzteile erhält.
Bei Rückfragen stehe ich gerne zur Verfügung und ich freue mich über jede hilfreiche Anmerkung bzw. Verbesserungsvorschläge.
PS: hier der Link für die Datei: https://www.herber.de/bbs/user/129196.xlsm
MfG Tarek

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

AW: VBA Datenbankauszug Ersatzteilliste

18.04.2019 04:06:49

fcs

AW: VBA Datenbankauszug Ersatzteilliste

18.04.2019 04:06:49

fcs

Hallo Tarek,
hier mal ein erster Ansatz für das Makro-Ausführen.
LG
Franz

Private Sub commandbutton2_click()
'Ausführen
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Dim lngZeile As Long, lngZeileQ As Long
Dim arrFilter() As String, intFilter As Integer
Set wksZiel = Worksheets("Tabelle2")
If Me.ComboBox1.ListIndex  -1 And Me.ComboBox2.ListIndex  -1 Then
If fncCheckSheetName(Me.ComboBox1.Value & " " & Me.ComboBox2.Value, ThisWorkbook) =  _
False Then
MsgBox "Blatt zu Pumpe """ & Me.ComboBox1.Value & " " & Me.ComboBox2.Value _
& """ nicht vorhanden!"
GoTo Beenden
End If
Set wksQuelle = Worksheets(Me.ComboBox1.Value & " " & Me.ComboBox2.Value)
If Me.ComboBox3.ListIndex  -1 Then
intFilter = intFilter + 1
ReDim Preserve arrFilter(1 To intFilter)
arrFilter(intFilter) = Me.ComboBox3.Value
End If
If Me.ComboBox4.ListIndex  -1 Then
intFilter = intFilter + 1
ReDim Preserve arrFilter(1 To intFilter)
arrFilter(intFilter) = Me.ComboBox4.Value
End If
If Me.ComboBox5.ListIndex  -1 Then
intFilter = intFilter + 1
ReDim Preserve arrFilter(1 To intFilter)
arrFilter(intFilter) = Me.ComboBox5.Value
End If
If Me.ComboBox6.ListIndex  -1 Then
intFilter = intFilter + 1
ReDim Preserve arrFilter(1 To intFilter)
arrFilter(intFilter) = Me.ComboBox6.Value
End If
If intFilter = 0 Then
MsgBox "Es wurde kein Werkstoff für ein Bauteil ausgewählt"
Else
With wksZiel
'Filterkriterien eintragen
.Range("F76").Value = ComboBox1.Value
.Range("F77").Value = ComboBox2.Value
.Range("F78").Value = ComboBox3.Value
.Range("F79").Value = ComboBox4.Value
.Range("F80").Value = ComboBox5.Value
.Range("F81").Value = ComboBox6.Value
lngZeile = .Cells(.Rows.Count, 5).End(xlUp).Row
If lngZeile >= 87 Then
.Range(.Cells(87, 5), .Cells(lngZeile, 7)).ClearContents
End If
lngZeile = 86
End With
With wksQuelle
If .AutoFilterMode = True Then
If .FilterMode Then .ShowAllData
Else
.UsedRange.AutoFilter
End If
.AutoFilter.Range.AutoFilter field:=6, Criteria1:=arrFilter, Operator:= _
xlFilterValues
For lngZeileQ = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
If .Rows(lngZeileQ).Hidden = False Then
lngZeile = lngZeile + 1
wksZiel.Cells(lngZeile, 5).Value = .Cells(lngZeileQ, 8) 'Z_pos
wksZiel.Cells(lngZeile, 6).Value = .Cells(lngZeileQ, 2) 'Stüli-teil
wksZiel.Cells(lngZeile, 7).Value = .Cells(lngZeileQ, 3) 'Bezeichnung
End If
Next
.ShowAllData
.AutoFilterMode = False
End With
With wksZiel
.Activate
If lngZeile = 86 Then
MsgBox "keine Teile zur Werkstoffauswahl gefunden."
Else
With .Range(.Cells(86, 5), .Cells(lngZeile, 7))
.RemoveDuplicates Array(1, 2, 3), xlYes
End With
End If
End With
End If
Else
MsgBox "Bitte Pumpentyp und Baugröße auswählen!"
End If
Beenden:
End Sub
Function fncCheckSheetName(sName As String, Optional wkb As Workbook) As Boolean
Dim objSheet As Object
If wkb Is Nothing Then Set wkb = ActiveWorkbook
On Error GoTo Fehler
Set objSheet = wkb.Sheets(sName)
fncCheckSheetName = True
Fehler:
End Function

Beliebteste Forumthreads (12 Monate)

VBA Datenbankauszug Ersatzteilliste

Forumthread: VBA Datenbankauszug Ersatzteilliste

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread