AW: Daten in neues Tabellenblatt Autofilter
27.09.2021 11:33:08
Werner
Hallo,
teste mal:
Option Explicit
Const strPfad = "C:\Users\cg\Desktop\"
Private Sub CommandButton_OK_Click()
Dim Bestellung As Workbook, Basisdaten As Workbook
Dim strFileName As Variant, i As Long, j As Long
Dim raFund As Range, sh As Shape
Const strDateiname = "C:\Users\cg\Desktop\Test.xlsx"
Application.ScreenUpdating = False
'Vorlage öffnen
Set Bestellung = Workbooks.Open(strDateiname, UpdateLinks:=False, ReadOnly:=True)
'Basis öffnen
Set Basisdaten = BasisDatei_öffnen
If Not Basisdaten Is Nothing Then
MsgBox "Die Datei '" & Basisdaten.Name & "' wurde geöffnet.", vbInformation, "Hinweis"
'Bestellung unter Zielname speichern
Bestellung.SaveAs strPfad & ThisWorkbook.Worksheets("fenster").Range("B2").Value & " " _
& ThisWorkbook.Worksheets("fenster").Range("D2").Value & ".xls"
'neue Zuweisung, da die Datei ja jetzt unter einem anderen Namen gespeichert wurde
Set Bestellung = Workbooks(ThisWorkbook.Worksheets("fenster").Range("B2") & " " _
& ThisWorkbook.Worksheets("fenster").Range("D2").Value & ".xls")
'Prüfen ob in Basisdaten in Spalte D AJ vorhanden ist
If WorksheetFunction.CountIf(Basisdaten.Worksheets("Fenster- und Terrassentüren").Columns("D"), "AJ") > 0 Then
'Wenn ja, Spalte D nach AJ filtern und Filterergebnis (Spalte A) kopieren
With Basisdaten.Worksheets("Fenster- und Terrassentüren")
.Range("A2").AutoFilter field:=4, Criteria1:="AJ"
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Columns(1).Copy
Bestellung.Worksheets("AJ Warema").Range("A19").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
.Range("A2").AutoFilter
Bestellung.Save
End With
Else
MsgBox "Fehler: Suchbegriff ""AJ"" ist in Spalte D nicht vorhanden."
End If
End If
With Basisdaten.Worksheets("Fenster- und Terrassentüren")
For i = 3 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A") "" Then
Bestellung.Worksheets("fenster").Cells(i + 6, "A") = .Cells(i, "A").Value
Bestellung.Worksheets("fenster").Cells(i + 6, "B") = .Cells(i, "B").Value
Bestellung.Worksheets("fenster").Cells(i + 6, "C") = .Cells(i, "C").Value
Bestellung.Worksheets("fenster").Cells(i + 6, "D") = .Cells(i, "D").Value
Bestellung.Worksheets("fenster").Cells(i + 6, "E") = Split(.Cells(i, "E").Value, "×")(0)
Bestellung.Worksheets("fenster").Cells(i + 6, "F") = Split(.Cells(i, "E").Value, "×")(1)
Bestellung.Worksheets("fenster").Cells(i + 6, "G") = .Cells(i, "H").Value
End If
Next i
End With
'Suchen und kopieren der Bilder
Bestellung.Worksheets("fenster").Activate
With Bestellung.Worksheets("Fenster")
.Columns("H").ColumnWidth = 37.6
For j = 9 To .Cells(.Rows.Count, "A").End(xlUp).Row
If .Cells(j, "A") "" Then
Set raFund = Basisdaten.Worksheets("Fenster- und Terrassentüren").Columns("A").Find(what:=.Cells(j, "A"), _
LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
For Each sh In Basisdaten.Worksheets("Fenster- und Terrassentüren").Shapes
If sh.TopLeftCell.Address = raFund.Offset(, 8).Address Then
sh.Copy
.Paste
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = .Cells(j, "H").Top
Selection.Left = .Cells(j, "H").Left
.Rows(j).RowHeight = 150
Selection.Height = .Rows(j).Height
Selection.Width = 200
End If
Next sh
End If
End If
Next j
.Range("A12").Select
End With
Bestellung.Save
Set raFund = Nothing
End Sub
Gruß Werner