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