AW: Range erweitern in Makro
06.06.2021 13:27:04
oraculix
Vielen Dank genau so brauche ich das!!
noch ne kurze frage dazu?
Wenn die suchabfrage nichts gefunden liefert sollte das Makro zu Tabelle Faforiten aktivieren.
'Nach dem suchen wird in Tabelle "Gefunden" der gesuchte Eintrag gelistet
Public Sub AnsehenFindenUndKopieren2(Optional ByVal sWord As String)
Dim Zellen As Range
Call GefundenDBLÖSCHEN
ActiveSheet.Range("A2:B50").Interior.ColorIndex = 1
If sWord = vbNullString Then sWord = InputBox(Prompt:="Suchbegriff:", Default:="Filmname")
If sWord vbNullString Then
With Sheets("FilmeAnsehen").UsedRange
With .Columns(.Columns.Count + 1)
.FormulaR1C1Local = "=Wenn(IstZahl(Suchen(""" & sWord & """;ZS1&ZS2&ZS8));1;"""")"
If WorksheetFunction.Sum(.Cells) > 0 Then Set Zellen = .SpecialCells(xlCellTypeFormulas, 1)
.ClearContents
End With
End With
If Zellen Is Nothing Then
MsgBox "Nichts gefunden", vbInformation, "Information"
Else
Zellen.EntireRow.Copy Sheets("Gefunden").Cells(2, 1)
'Sheets("Gefunden").Cells(2, 1).PasteSpecial xlPasteValues
Sheets("Gefunden").Select
End If
End If
Range("A1").Activate
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
If Target.Row = 1 Then
Call AnsehenFindenUndKopieren2(Target.Text)
Cancel = True
End If
If Target.Address = "$B$1" Then
Call AnsehenFindenUndKopieren2(Target.Text)
Cancel = True
End If
'Application.GoTo Reference:=Worksheets("Faforiten").Range("A1")
End Sub
