Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1252to1256
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

@ Sepp: Große Bitte

@ Sepp: Große Bitte
Claudia
Hallo Sepp,
ich haben einen ganze große Bitte.
Ich habe meine "Anforderungen" ausnahmsweise mal in die Excel-Tabelle direkt gepackt, so dass es einfacher ist.
https://www.herber.de/bbs/user/79229.xls
Vielelicht hast Du ja mal Zeit Dir das anzuschauen. Ist auf alle Fälle doch sehr umfangreich.
Vielen vielen Dank!
Liebe Grüße
Claudia

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: @ Sepp: Große Bitte
06.03.2012 17:29:59
Josef

Hallo Claudia,
teste mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub treffer()
  Dim rngValues As Range, rngTarget As Range, rngRow As Range
  Dim rngOutput As Range, rng As Range
  Dim lngMaxRow As Long, lngCount As Long, lngRow As Long, lngIndex As Long
  Dim lngRowsCount As Long, lngColumnsCount As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
  End With
  
  Set rngValues = Sheets("Anfang").Range("E5:E14")
  'Bereich mit den Suchbegriffen, kann einfach angepasst werden!
  
  Set rngTarget = Sheets("Treffer").Range("A3:J58")
  'Durchsuchter Bereich, kann einfach angepasst werden!
  
  Set rngOutput = Sheets("Anfang").Range("H1:Q20")
  'Ausgabebereich, der weitere Code orientiert sich an den angegebenen Bereichen.
  'Die Zeilen und Spalten-Anzahl im Ausgabebereich bestimmen wie viele Zeilen/Spalten
  'aus dem durchsuchten Bereich eingefügt werden. H1:Q20 = 20 Zeilen, 10 Spalten
  'es werden aus dem durchsuchten bereich jeweils die Folgenden 20, 10 Spalten breiten
  'Bereiche in den Ausgabebereich eingefügt
  
  rngOutput.ClearContents
  lngRowsCount = rngOutput.Rows.Count
  lngColumnsCount = rngOutput.Columns.Count
  
  Sheets("Anfang").Range("I24") = "Fehler"
  
  For Each rngRow In rngTarget.Rows
    lngCount = 0
    If Application.CountA(rngRow) > 0 Then
      For Each rng In rngValues
        If rng <> "" Then
          If Application.CountIf(rngRow, rng) > 0 Then lngCount = lngCount + 1
        End If
      Next
      If lngCount > lngMaxRow Then
        lngMaxRow = lngCount
        lngRow = rngRow.Row
      End If
    End If
  Next
  
  If lngRow > 0 Then
    Sheets("Anfang").Range("I24") = lngRow
    lngRow = lngRow - rngTarget.Rows(1).Row + 1
    Sheets("Anfang").Range("H1").Resize(1, lngColumnsCount) = rngTarget.Rows(lngRow).Value
    For lngIndex = 2 To lngRowsCount
      Sheets("Anfang").Cells(lngIndex, 8).Resize(1, lngColumnsCount) = rngTarget.Rows(lngRow).Offset(0, (lngIndex - 1) * 10).Value
    Next
  End If
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'treffer'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
  End With
  
  Set rngValues = Nothing
  Set rngTarget = Nothing
  Set rngOutput = Nothing
  Set rngRow = Nothing
  Set rng = Nothing
End Sub



« Gruß Sepp »

Anzeige
AW: @ Sepp: Große Bitte
06.03.2012 18:31:47
Claudia
Hallo Sepp,
Du bist einfach der Beste. Echt genial, dass Du mir geholfen hast.
Bin schon dran am testen. Auf den ersten Blick sieht es super aus. Sage Dir gleich mehr.
Liebe Grüße
Claudia
AW: @ Sepp: Große Bitte
06.03.2012 20:20:35
Claudia
Hallo Sepp,
also es funktioniert einfach super. Eine Riesen Erleichterung!
Vielen, vielen vielen Dank für Deine (erneute) Hilfe!
Bist der Beste!
Liebe Grüße
Claudia

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige