Array durchsuchen Werte ausgeben

Hallo zusammen,
seit mehreren Tagen hänge ich an einem Problem und komme nicht mehr weiter. Zwar habe ich ähnliche Problemstellungen gefunden, jedoch unterschieden sich diese doch ein wenig.
Folgendes Problem kann ich leider nicht lösen.
Ich möchte mit Hilfe eines active-X-Steuerelement den Bereich BE10:CO44 des Tabellensheets1 nach einem Suchkriterium durchsuchen. Das Suchkriterium ist eine Zahl und wird in der Zelle X des Tabellensheets 2 eingegeben. Im nächsten Schritt sollen die Werte der Zeile 6 + 7 (im Tabellensheet 1) jener Spalten, in denen sich das Suchkriterium befindet, in das Tabellensheet 2 horizontal kopiert werden.
Ich hoffe ich konnte meine Problem ausreichend darstelle und wäre euch um jede Hilfe dankbar.
LG
Viktor

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

If Worksheetfunction.CountA(Range("BE46:CO46")) > 0 Then Intersect(Range("6:7"), Range("BE46:CO46").SpecialCells(xlcelltypeformulas, 1).EntireColumn) _ .Copy ... hier dann der Code zum einfügen End if

Hallo
eine mögliche Variante:

Option Explicit
Sub SpezialSuche()
Dim suchArr As Variant, dadaArr As Variant, gefArr As Variant
Dim Zähler As Long, x As Long, y As Long
Dim wasSuchen As String
' der zu durchsuchende Bereich u. die Daten in ein Array
suchArr = ThisWorkbook.Worksheets("Tabelle1").Range("BE10:CO44").Value
dadaArr = ThisWorkbook.Worksheets("Tabelle1").Range("BE6:CO7").Value
' maximale Fundstellen, wenn in jeder Spalte der Wert gefunden wird
ReDim gefArr(1 To 2, 1 To 37)
' Was soll gesucht werden
wasSuchen = ThisWorkbook.Worksheets("Tabelle2").Range("B2").Value
If wasSuchen = vbNullString Then MsgBox "Nichts zu suchen": Exit Sub
' Suchvorgang im Array
Zähler = 1
For x = 1 To UBound(suchArr, 2)
For y = 1 To UBound(suchArr, 1)
If InStr(suchArr(y, x), wasSuchen) > 0 Then
gefArr(1, Zähler) = dadaArr(1, x)
gefArr(2, Zähler) = dadaArr(2, x)
Zähler = Zähler + 1
Exit For
End If
Next y
Next x
If Zähler = 1 Then MsgBox "Nichts gefunden": Exit Sub
' Wurde was gefunden dann Array der Fundstellen verkleinern
ReDim Preserve gefArr(1 To 2, 1 To Zähler - 1)
' Ausgabe beginnend bei Zelle B4 im Tabellenblat 'Ergebnis'
With ThisWorkbook.Worksheets("Tabelle2")
.Range("B4").End(xlDown).ClearContents  ' eventuelle Daten löschen
.Range("B4").Resize(UBound(gefArr, 1) - LBound(gefArr, 1) + 1, UBound(gefArr, 2) - LBound( _
gefArr, 2) + 1) = gefArr
End With
End Sub

mfg GraFri

' Ausgabe beginnend bei Zelle B4 im Tabellenblat 'Tabelle2' With ThisWorkbook.Worksheets("Tabelle2") .Range("B4").End(xlToRight).ClearContents ' eventuelle Daten löschen .Range("B5").End(xlToRight).ClearContents ' eventuelle Daten löschen .Range("B4").Resize(UBound(gefArr, 1) - LBound(gefArr, 1) + 1, UBound(gefArr, 2) - LBound( _ gefArr, 2) + 1) = gefArr End With

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Array durchsuchen Werte ausgeben

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread