Variable Suche, Spalten über Userform de

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Curly,
teste mal:

Option Explicit

Sub Search()

    Dim c As Range
    Dim lngZeile As Long
    Dim rngBereich As Range
    Dim lngAnzahl As Long
    Dim strFirst As String
    Dim arrStock As Variant
    Dim i, ii, X As Byte
    Dim iAnzahl As Integer
    Redim vTemp(0 To 6, 0 To 100) As Variant
    Dim iIndx As Integer
    Dim AnzahlBetriebe As Integer
    Dim iSuche As Integer
    Dim lngIndex As Long

    UserForm1.ListBox1.Clear

    arrStock = Array("StockA", "StockB", "StockC")

    For i = LBound(arrStock) To UBound(arrStock)
        With Sheets(CStr(arrStock(i)))
            Set rngBereich = Nothing
            For lngIndex = 2 To 7
                If Worksheets("Suche").Cells(lngIndex, 2).Value = "ja" Then
                    If rngBereich Is Nothing Then
                        Set rngBereich = .Columns(lngIndex - 1)
                    Else
                        Set rngBereich = Union(rngBereich, .Columns(lngIndex - 1))
                    End If
                End If
            Next lngIndex
            Set c = rngBereich.Find(UserForm1.TextBox1.Text, LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                strFirst = c.Address
                Do
                    ' If c.Row = lngZeile Then GoTo naechste

                    vTemp(0, iAnzahl) = arrStock(i)
                    For iIndx = 1 To 6
                        vTemp(iIndx, iAnzahl) = .Cells(c.Row, iIndx)
                    Next iIndx
                    iAnzahl = iAnzahl + 1
                    ' lngZeile = c.Row

                    naechste:
                    Set c = rngBereich.FindNext(c)
                Loop While Not c Is Nothing And c.Address <> strFirst
            End If
        End With

    Next i

    If iAnzahl = 0 Then
        MsgBox "Es wurde keine Treffer gefunden!", vbInformation, "Hinweis"
        GoTo ende
    End If

    Redim arrTemp(0 To 6, 0 To iAnzahl - 1)
    Redim Preserve vTemp(0 To 6, 0 To iAnzahl - 1)

    If (iAnzahl - 1) = 0 Then
        Redim arrTemp(1 To 1, 0 To 6)
        For i = 0 To 6
            arrTemp(1, i) = vTemp(i, 0)
        Next i
    Else
        arrTemp = WorksheetFunction.Transpose(vTemp)
    End If

    UserForm1.ListBox1.List() = arrTemp

    ende:
    Erase vTemp
    Erase arrTemp

End Sub

Gruß
Nepumuk

Hallo Curly,
teste mal:

Option Explicit

Public Sub Search()

    Dim objCell As Range, objRange As Range
    Dim objDictionary As Object
    Dim avntValues() As Variant, vntItem As Variant
    Dim lngIndex As Long, ialngIndex As Long, lngColumn As Long
    Dim strFirstAddress As String

    UserForm1.ListBox1.Clear

    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")

    For Each vntItem In Array("StockA", "StockB", "StockC")

        With Worksheets(vntItem)

            Set objRange = Nothing

            For lngIndex = 2 To 7
                If Worksheets("Suche").Cells(lngIndex, 2).Value = "ja" Then
                    If objRange Is Nothing Then
                        Set objRange = .Columns(lngIndex - 1)
                    Else
                        Set objRange = Union(objRange, .Columns(lngIndex - 1))
                    End If
                End If
            Next

            Set objCell = objRange.Find(UserForm1.TextBox1.Text, LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

            If Not objCell Is Nothing Then

                strFirstAddress = objCell.Address

                Do

                    If objCell.Row > 1 Then

                        If Not objDictionary.Exists(Key:=vntItem & "|" & objCell.Row) Then

                            Call objDictionary.Add(Key:=vntItem & "|" & objCell.Row, Item:=vbNullString)

                            Redim Preserve avntValues(6, ialngIndex)

                            avntValues(0, ialngIndex) = vntItem

                            For lngColumn = 1 To 6
                                avntValues(lngColumn, ialngIndex) = .Cells(objCell.Row, lngColumn)
                            Next

                            ialngIndex = ialngIndex + 1

                        End If
                    End If

                    Set objCell = objRange.FindNext(After:=objCell)

                Loop Until objCell.Address = strFirstAddress
            End If
        End With

    Next

    If ialngIndex = 0 Then
        MsgBox "Es wurde keine Treffer gefunden!", vbInformation, "Hinweis"
    Else
        UserForm1.ListBox1.Column = avntValues
    End If
End Sub

Gruß
Nepumuk

If ialngIndex = 0 Then MsgBox "Es wurde keine Treffer gefunden!", vbInformation, "Hinweis" Else For lngIndex = LBound(avntValues, 2) To UBound(avntValues, 2) avntValues(6, lngIndex) = Format(avntValues(6, lngIndex), "#,##0.00 ") avntValues(7, lngIndex) = Format(avntValues(7, lngIndex), "#,##0.00 ") Next lngIndex UserForm1.ListBox1.Column = avntValues End If

Beliebteste Forumthreads (12 Monate)

Variable Suche, Spalten über Userform de

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Variable Suche, Spalten über Userform de

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread