AW: VBA copy ohne doppelte Werte
29.05.2020 07:46:31
Kerumi
Habe mal diesen Code gefunden:
Sub Werte_ohne_Redundanzen_Kopieren()
'Kopiert alle Werte der Spalte B EINMALIG nach Spalte C - ohne Redundanzen
'24.11.2011, NoNet - www.excelei.de
Dim lngZQ As Long, lngZZ As Long 'Zeilen-Variablen für Quelle/Ziel
Dim lngSQ As Long, lngSZ As Long 'Spalten-Variablen für Quelle/Ziel
lngSQ = 2 'Werte aus Quell-Spalte 2 = Spalte B
lngSZ = 3 'Werte nach Ziel-Spalte 3 = Spalte C
Columns(lngSZ).ClearContents 'Zielspalte zuvor löschen !
For lngZQ = 2 To Cells(Rows.Count, lngSQ).End(xlUp).Row
'Per ZÄHLENWENN() prüfen, ob Wert bereits in ZIEL-Spalte vorhanden ist :
If Application.CountIf(Columns(lngSZ), Cells(lngZQ, lngSQ)) = 0 Then
'Wenn der Wert noch NICHT in der ZIEL-Spalte vorhanden ist :
lngZZ = Cells(Rows.Count, lngSZ).End(xlUp).Row + 1
Cells(lngZZ, lngSZ) = Cells(lngZQ, lngSQ)
End If
Next
End Sub
Der sieht eigentlich ganz gut aus, für das was ich machen möchte, jedoch muss ich vorab nach dem Begriff Beckhoff filtern.
Bisheriger Code dafür:
Sub kopierenBT()
Dim variable As String
variable = [A1]
'Blatt auswählen und Startpunkt (A4)festlegen'
With Sheets("BT Projekte ganz").Range("A4").CurrentRegion
'Field= Spalte (Nr) Criterial= Suchbegriff'
.AutoFilter Field:=7, Criteria1:="Beckhoff"
'Resize= ,Anzahl Spalten nach ausgewählter Reihe werden mitkopiert'
.Resize(, 2).Offset(1, 6).SpecialCells(xlCellTypeVisible).Copy
End With
'Schreibe Daten in Blatt'
Sheets("Beckhoff").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Anfangspunkt definieren (A4)'
Sheets(variable).Range("A4").CurrentRegion.AutoFilter
End Sub
wie knüpfe ich das hier am besten rein?
Ebenso wäre es toll den bisherigen Filtercode zusammenzuführen über die 2 Tabellenblätter. (Blatt 1+2). Ist das möglich? Oder muss ich das in 2 separaten Spalten machen?
2. Teil des Filtercodes bisher: (Funzt nicht so dolle)
Sub kopierenAT()
Dim variable As String
variable = [A1]
'Blatt auswählen und Startpunkt (A4)festlegen'
With Sheets("AT Projekte ganz").Range("A4").CurrentRegion
'Field= Spalte (Nr) Criterial= Suchbegriff'
.AutoFilter Field:=9, Criteria1:="Beckhoff"
'Resize= ,Anzahl Spalten nach ausgewählter Reihe werden mitkopiert'
.Resize(, 2).Offset(1, 8).SpecialCells(xlCellTypeVisible).Copy
End With
'Schreibe Daten in Blatt'
Sheets("Beckhoff").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
'Anfangspunkt definieren (F4)'
Sheets(variable).Range("F4").CurrentRegion.AutoFilter
End Sub