Thema Datum  Von Nutzer Rating
Antwort
21.10.2020 11:03:02 maka93
NotSolved
21.10.2020 22:42:08 ralf_b
NotSolved
21.10.2020 23:04:38 Gast96263
NotSolved
Blau Zeilen aufgrund von Formelergebnis überspringen
22.10.2020 01:21:26 Gast3610
Solved
22.10.2020 08:06:02 maka93
NotSolved

Ansicht des Beitrags:
Von:
Gast3610
Datum:
22.10.2020 01:21:26
Views:
1031
Rating: Antwort:
 Nein
Thema:
Zeilen aufgrund von Formelergebnis überspringen

Unter Verwendung der Filter-Funktion ginge es so:

(derzeit nur für Office 365)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Option Explicit
 
Sub Test()
   
  Dim wksSrc    As Excel.Worksheet
  Dim wksDst    As Excel.Worksheet
  Dim rngFilter As Excel.Range
  Dim rngData   As Excel.Range
  Dim vntResult As Variant
   
  Set wksSrc = ThisWorkbook.Worksheets("SITE FM")
  Set wksDst = ThisWorkbook.Worksheets("Zieltabelle")
   
  With wksSrc
    Set rngFilter = .Range("AA1", .Cells(.Rows.Count, "AA").End(xlUp))
    Set rngData = .Range("A1:Z" & rngFilter(rngFilter.Cells.Count).Row)
    vntResult = "=(" & rngFilter.Address & "=""x"")"
    vntResult = .Evaluate(vntResult)
  End With
   
  If VarType(vntResult) = vbBoolean Then
    If CBool(vntResult) = False Then
      Call MsgBox("Es sind keine Datensätze markiert.", vbExclamation)
      Exit Sub
    End If
  End If
   
  With wksDst.Range("A1") '< Zelle zum Einfügen der Daten
     
    vntResult = WorksheetFunction.Filter(rngData, vntResult)
     
    On Error Resume Next
      'tritt hier ein Fehler auf, haben wir nur eine Datensatz als Ergebnis
      Set rngData = Nothing
      Set rngData = .Resize(UBound(vntResult, 1), UBound(vntResult, 2))
    On Error GoTo 0
     
    If rngData Is Nothing Then
      'nur eine Datensatz
      Set rngData = .Resize(1, UBound(vntResult))
    End If
     
    rngData.Value = vntResult
  End With
   
  Call MsgBox("Datensätze kopiert: " & rngData.Rows.Count, vbInformation, "Fertig")
   
End Sub

Ansonsten vielleicht so:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
Option Explicit
 
Sub Test()
   
  Dim wksSrc    As Excel.Worksheet
  Dim wksDst    As Excel.Worksheet
  Dim rngFilter As Excel.Range
  Dim rngData   As Excel.Range
   
  Set wksSrc = ThisWorkbook.Worksheets("SITE FM")
  Set wksDst = ThisWorkbook.Worksheets("Zieltabelle")
   
  With wksSrc
    Set rngFilter = .Range("AA1", .Cells(.Rows.Count, "AA").End(xlUp))
    Set rngData = .Range("A1:Z" & rngFilter(rngFilter.Cells.Count).Row)
  End With
   
  With wksDst
     
    Dim rngDst As Excel.Range
     
    Set rngDst = .Range("A1") '< Zelle zum Einfügen der Daten
    Set rngDst = rngDst.Resize(1, rngData.Columns.Count)
     
    Dim colResults  As VBA.Collection
    Dim rngResult   As Excel.Range
     
    Set colResults = New VBA.Collection
    Set rngResult = rngFilter.Find(What:="x", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, MatchByte:=False)
     
    If rngResult Is Nothing Then
      Call MsgBox("Es sind keine Datensätze markiert.", vbExclamation)
      Exit Sub
    Else
      On Error Resume Next
      Do
        Call colResults.Add(rngResult, rngResult.Address)
        If Err.Number <> 0 Then Exit Do
        Set rngResult = rngFilter.FindNext(rngResult)
      Loop
      On Error GoTo 0
    End If
     
    For Each rngResult In colResults
      rngDst.Value = rngData.Rows(1).Offset(rngResult.Row - rngData.Row).Value
      Set rngDst = rngDst.Offset(1)
    Next
     
  End With
   
  Call MsgBox("Datensätze kopiert: " & colResults.Count, vbInformation, "Fertig")
   
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
21.10.2020 11:03:02 maka93
NotSolved
21.10.2020 22:42:08 ralf_b
NotSolved
21.10.2020 23:04:38 Gast96263
NotSolved
Blau Zeilen aufgrund von Formelergebnis überspringen
22.10.2020 01:21:26 Gast3610
Solved
22.10.2020 08:06:02 maka93
NotSolved