Userform, VBA

Hej
1. tror du bliver nød til at lave en userform magen til den du har
2. ved valg af Afdeling skal du gennemtrave A kolonnen for mats og gemme de celler der matser i et array

3. ved valg af område (brug evt. array'et til at lave valglisten)laves ny array ud fra det første array

osv.

til sidst vil du kun have en celle tilbage, find rækken på cellen og du kan sætte value i alle felter ud fra det (cell(række,kolonne).value)

Hej Jan,

det lyder meget struktureret - du kan vel ikke komme med et kode eksempel  - er lidt på bar bund her - og har indtil videre ikke haft held med at googlesøge:-)

venlig hilsen Brian

Her er lidt kode

Option Explicit
Dim rList As Range
Dim aList1() As Range
Dim rCell As Range
Dim iCount As Integer
Dim msListBox As MSForms.ListBox

Private Sub ListBox1_Change()
    Lbox1
    With ListBox2
        .Clear
        .Visible = True
        Label2.Visible = True
        For iCount = 1 To UBound(aList1()) - 2
            .AddItem aList1(iCount).Value
        Next iCount
    End With
    Set msListBox = Me.ListBox2
    Test
End Sub
Private Sub Lbox1()
    ReDim aList1(1 To rList.Count)
    With ListBox1
        iCount = 1
        For Each rCell In rList
            If rCell.Value = .Value Then
                Set aList1(iCount) = rCell.Offset(0, 1)
                iCount = iCount + 1
            End If
        Next rCell
    End With
End Sub
Private Sub UserForm_Initialize()
    Set rList = Range("A2")
    Set rList = Range(rList, rList.End(xlDown))
    With Label1
        .Caption = Range("A1")
    End With
        With Label2
        .Caption = Range("B1")
        .Visible = False
    End With
    With ListBox1
        .Width = .Width * 1.25
        .List = rList.Value
    End With
    Set msListBox = Me.ListBox1
    Test
    With ListBox2
        .Width = .Width * 1.25
        .Visible = False
    End With
End Sub
Sub Test()
    Dim i As Long, j As Long
    Dim nodupes As New Collection
    Dim Swap1, Swap2, Item
   
   
    With msListBox
   
        For i = 0 To .ListCount - 1
            On Error Resume Next
            nodupes.Add .List(i), CStr(.List(i))
        Next i
        On Error GoTo 0
        .Clear
        For i = 1 To nodupes.Count - 1
            For j = i + 1 To nodupes.Count
                If nodupes(i) > nodupes(j) Then
                    Swap1 = nodupes(i)
                    Swap2 = nodupes(j)
                    nodupes.Add Swap1, before:=j
                    nodupes.Add Swap2, before:=i
                    nodupes.Remove i + 1
                    nodupes.Remove j + 1
                End If
            Next j
        Next i
        For Each Item In nodupes
            .AddItem Item
        Next Item
    End With
End Sub

mvh Jan

Denne er bedre

Option Explicit
Dim rList As Range, rCell As Range
Dim msListBox As MSForms.ListBox
Dim cList As New Collection
Dim iCount As Integer

Private Sub ListBox1_Change()
    Lbox2
End Sub
Private Sub UserForm_Initialize()
    TilpasLayout
    Lbox1
End Sub
Private Sub Lbox2()
    Set rList = Range("A2")
    Set rList = Range(rList, rList.End(xlDown))
    With ListBox1
        iCount = 1
        For Each rCell In rList
            If rCell.Value = .Value Then
                Cells(iCount, 100) = rCell.Offset(0, 1)
                iCount = iCount + 1
            End If
        Next rCell
    End With
    If Cells(1, 100) <> "" Then Set rList = Cells(1, 100)
    If Cells(2, 100) <> "" Then Set rList = Range(rList, rList.End(xlDown))
    ListBox2.List = rList.Value
    For Each rCell In rList
        rCell = ""
    Next rCell
    Set msListBox = Me.ListBox2
    ClearList
End Sub
Private Sub Lbox1()
    Set rList = Range("A2")
    Set rList = Range(rList, rList.End(xlDown))
    With ListBox1
        .List = rList.Value
    End With
    Set msListBox = Me.ListBox1
    ClearList
End Sub
Private Sub TilpasLayout()
    With Me
        .Caption = "Ret data"
    End With
    With Label1
        .Caption = Range("A1")
    End With
        With Label2
        .Caption = Range("B1")
    End With
End Sub
Sub ClearList()
    Dim i As Long, j As Long
    Dim nodupes As New Collection
    Dim Swap1, Swap2, Item
    With msListBox
        For i = 0 To .ListCount - 1
            On Error Resume Next
            nodupes.Add .List(i), CStr(.List(i))
        Next i
        On Error GoTo 0
        .Clear
        For i = 1 To nodupes.Count - 1
            For j = i + 1 To nodupes.Count
                If nodupes(i) > nodupes(j) Then
                    Swap1 = nodupes(i)
                    Swap2 = nodupes(j)
                    nodupes.Add Swap1, before:=j
                    nodupes.Add Swap2, before:=i
                    nodupes.Remove i + 1
                    nodupes.Remove j + 1
                End If
            Next j
        Next i
        For Each Item In nodupes
            .AddItem Item
        Next Item
    End With
End Sub

Hej Jan,

Super - rigtig mange tak:-)
Må jeg vende tilbage I morgen, hvis jeg har et par opfølgende spørgsmål?

venlig hilsen Brian

Prøv bare har jeg tid svarer jeg

Hej Jan det er super.

din kode virker og jeg har nu fået rettet til, således at jeg kan vælge på 5 niveauer:-)

Hvis, og kun hvis du har tid, har jeg et par opfølgende spørgsmål.

1. Når jeg trækker niveau 4 ind,som er et datoformat, laver excel det om til et tal og det same sker, når jeg trækker niveau 5 ind, som er tid. Er der en made, så jeg kan bibeholde formaterne I userformen.

2. Når jeg har valgt 5 niveau (tiden I kolonne E) vil jeg gerne have at dataen fra kolonne F til kolonne X trækkes ind I userformen.

3 når der trykkes "gem" skal de redigerede data lægges tilbage.

På forhånd mange tak - det er virkelig en stor hjælp:-)

Har nok lidt tid søndag

mvh Jan

2. Løkke der ser ned gennem A kolonnen til mats test om B kolonnen matser hvis nej  videre i A kolonnen ellers teste C kolonnen for mats osv., når alle 5 matser så er rækken fundet og resten kan overføres til textboxen "textbox1.value=Cells(række,kolonne)"

3. Gem overfør "Cells(række,kolonne)=textbox.value"

1. mon det ikke er  noget alla "listbox.format="dd-mm-åååå"
ej testet

Mvh Jan

Super:-) kunne du evt. komme med et kodeeksempel til nummer 2  - der er jeg stadig lidt på bar bund. 2 og 3 er til at gå til.

takker og god weekend:-)

Option Explicit
Dim ws As Worksheet
Dim rList As Range, rCell As Range, rRaekke As Range
Dim msListBox As MSForms.ListBox
Dim cList As New Collection
Dim iCount As Integer, iRaekke As Integer

Private Sub Overfoerdata()
    Set ws = ActiveSheet ' kan også navngives så erstat ActiveSheet med Sheets("Ark1")
    Set rRaekke = ws.Range("A1")
    Set rRaekke = Range(rRaekke, rRaekke.End(xlDown))
    For Each rCell In rRaekke
        ' nedenstående ligger data ind i arket
        Select Case rCell.Column
            Case 1
                Cells(iRaekke, rCell.Column) = ListBox1.Value
            Case 2
                Cells(iRaekke, rCell.Column) = ListBox2.Value
            Case 3
                Cells(iRaekke, rCell.Column) = ListBox3.Value
            ' osv.
        End Select
    Next rCell
End Sub
Private Sub FindRaekke()
    Set ws = ActiveSheet
    Set rList = Range("A2")
    Set rList = Range(rList, rList.End(xlDown))
    For Each rCell In rList
        If rCell.Value = ListBox1.Value Then 'Tjek A til mats
            If rCell.Offset(0, 1).Value = ListBox2.Value Then 'Tjek om B matser osv.
                If rCell.Offset(0, 2).Value = ListBox3.Value Then
                    If rCell.Offset(0, 3).Value = ListBox4.Value Then
                        If rCell.Offset(0, 4).Value = ListBox5.Value Then
                            iRaekke = rCell.Row
                        End If
                    End If
                End If
            End If
        End If
    Next rCell
End Sub

ej testet

Mvh Jan

Hej jan det er super - så har jeg et godt grundlag for mit videre arbejde - rigtig mange tak for hjælpen:-)

velbekomme