Thema Datum  Von Nutzer Rating
Antwort
20.12.2021 17:09:37 VBA Newbie
NotSolved
08.02.2022 18:46:14 Gast74525
NotSolved
18.02.2022 08:25:53 Martina Soppke
NotSolved
18.02.2022 10:39:08 Mase
NotSolved
18.02.2022 13:16:59 Martina Soppke
NotSolved
Blau Zeilen mit gleichem Wert kopieren
18.02.2022 15:42:19 Mase
NotSolved
18.02.2022 16:41:37 Gast67933
NotSolved
18.02.2022 17:30:20 Mase
NotSolved
21.02.2022 05:48:23 Gast53917
NotSolved
21.02.2022 14:49:36 Mase
NotSolved
22.02.2022 08:24:55 Martina Soppke
NotSolved
22.02.2022 09:15:24 Mase
NotSolved
22.02.2022 09:49:09 Martina Soppke
NotSolved
22.02.2022 10:14:29 Mase
NotSolved
22.02.2022 12:21:34 Martina Soppke
NotSolved
22.02.2022 12:36:13 Gast71106
NotSolved
22.02.2022 17:02:38 Martina Soppke
NotSolved
22.02.2022 17:36:20 ralf_b
NotSolved
23.02.2022 05:44:35 Martina Soppke
NotSolved
23.02.2022 06:33:40 Mase
NotSolved
11.03.2022 13:28:23 Martina Soppke
NotSolved
11.03.2022 13:38:08 Mase
NotSolved

Ansicht des Beitrags:
Von:
Mase
Datum:
18.02.2022 15:42:19
Views:
519
Rating: Antwort:
  Ja
Thema:
Zeilen mit gleichem Wert kopieren

Hier aus einem Projekt:

 

Beachte die Kommentare:

Option Explicit
Private Const sZIELARBEITSBLATTNAME As String = "Ziel" '**** hier kommt der Zielarbeitsblattname hin

Sub main()

    Dim wks             As Excel.Worksheet
    Dim sSuchbegriff    As String
    
    On Error GoTo FinishErr
    
    sSuchbegriff = "Bauer" '*** hier Deine Inputbox
    
    
    '*** Übersichtsblatt zurücksetzen
    Worksheets(sZIELARBEITSBLATTNAME).Cells.ClearContents
    Worksheets(sZIELARBEITSBLATTNAME).Cells.ClearFormats

    Application.ScreenUpdating = False
    '*** durchlaufe jedes Arbeitsblatt; ausser Zielarbeitsblatt
    For Each wks In ThisWorkbook.Worksheets
        If Not wks.Name = Worksheets(sZIELARBEITSBLATTNAME).Name Then
            Call FrageArbeitsblatt(wks.Name, sSuchbegriff)
        End If
    Next wks
    




FinishErr:
Application.ScreenUpdating = True


End Sub

Sub FrageArbeitsblatt(ByVal sName As String, ByVal sSuchWert As String)

    Dim rngFilterBereich            As Excel.Range
    Dim rngIntersect                As Excel.Range
    
    With Worksheets(sName)
        '*** Möglichen Filter entfernen
        If .AutoFilterMode = True Then .AutoFilterMode = False
        '*** Autofilter anwenden und Filter setzen
        Set rngFilterBereich = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(1, .Columns.Count).End(xlToLeft).Column))
        rngFilterBereich.AutoFilter Field:=2, Criteria1:=sSuchWert
        '*** Bereich zum kopieren definieren
        Set rngIntersect = Application.Intersect(rngFilterBereich, rngFilterBereich.Offset(1, 0), rngFilterBereich.SpecialCells(xlCellTypeVisible))
        '*** Falls was vorhanden, in Überischtsblatt übertragen
        If Not rngIntersect Is Nothing Then
            Call rngIntersect.Copy
            Call Worksheets(sZIELARBEITSBLATTNAME).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial(xlPasteValuesAndNumberFormats)
            Application.CutCopyMode = False
            .UsedRange.EntireColumn.AutoFit
            Application.Goto Reference:=Worksheets(sZIELARBEITSBLATTNAME).Range("A1")
        End If
        '*** Filter lösen
        rngFilterBereich.AutoFilter
        .AutoFilterMode = False
    End With
    
End Sub



 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
20.12.2021 17:09:37 VBA Newbie
NotSolved
08.02.2022 18:46:14 Gast74525
NotSolved
18.02.2022 08:25:53 Martina Soppke
NotSolved
18.02.2022 10:39:08 Mase
NotSolved
18.02.2022 13:16:59 Martina Soppke
NotSolved
Blau Zeilen mit gleichem Wert kopieren
18.02.2022 15:42:19 Mase
NotSolved
18.02.2022 16:41:37 Gast67933
NotSolved
18.02.2022 17:30:20 Mase
NotSolved
21.02.2022 05:48:23 Gast53917
NotSolved
21.02.2022 14:49:36 Mase
NotSolved
22.02.2022 08:24:55 Martina Soppke
NotSolved
22.02.2022 09:15:24 Mase
NotSolved
22.02.2022 09:49:09 Martina Soppke
NotSolved
22.02.2022 10:14:29 Mase
NotSolved
22.02.2022 12:21:34 Martina Soppke
NotSolved
22.02.2022 12:36:13 Gast71106
NotSolved
22.02.2022 17:02:38 Martina Soppke
NotSolved
22.02.2022 17:36:20 ralf_b
NotSolved
23.02.2022 05:44:35 Martina Soppke
NotSolved
23.02.2022 06:33:40 Mase
NotSolved
11.03.2022 13:28:23 Martina Soppke
NotSolved
11.03.2022 13:38:08 Mase
NotSolved