Avatar billede blolsen Juniormester
08. marts 2017 - 09:31 Der er 11 kommentarer og
2 løsninger

Userform, VBA

Hej, jeg har en udfordring, som jeg håber I kan hjælpe mig med.

Jeg har lavet en combobox, hvor jeg  - med .addItem  - har en liste af afdelinger, som brugeren kan vælge, der skal indtastes informationer på. Når brugeren vælger en bestemt afdeling angiver userformen automatisk en dato og tid. Brugeren kan også vælge  - via en combobox - et bestemt "område", dvs. "general" og "almen" samt om om det er patienter kl. 9 eller kl 15. Der samlet set 32 kolonner, som brugeren kan indtaste I via userformen. Dette virker.

SÅ DET jeg gerne vil jhave hjælp til at at brugerne på et senere tidspunkt kan trække rækken tilbage I userformen og korrigere indtastningerne.

Dvs. hvis der vælges en afdeling skal brugeren kunne vælge relaterede områder I en ny box. Når der er valgt område skal brugeren vælge om det er patienter klokken 9 eller kl 15. Og derefter skal brugeren kunne vælge dato og efterfølgende tid - og her er der rigtig mange valgmuligheder. Når brugeren har foretager valgene skal de resterende kolonner trækkes med ind I userformen og brugeren skal kunne forestage rettelser og lægge dataene retur på rækken.

Er dette muligt?

Afdeling    Område    Patienter kl.    Dato                  Tid        senge  A sengeB 
VITA    generel     Patient kl 9    03-06-2017    09:01:00               
VITA    generel     Patient kl 15    03-06-2017    13:02:04               
VITA    generel     Patient kl 9    04-06-2017    09:02:33               
VITA    generel     Patient kl 15    04-06-2017    13:04:54               
VITA    almen    Patient kl 15    03-06-2017    13:06:01               
VITA    almen    Patient kl 9    04-06-2017    09:06:40               
VITA    almen    Patient kl 15    04-06-2017    13:12:33               
FAM KIR    almen    Patient kl 9    03-06-2017    09:13:51               
FAM KIR    generel     Patient kl 9    04-06-2017    09:15:51               

På forhånd rigtig mange tak.
Avatar billede Jan Hansen Ekspert
08. marts 2017 - 15:58 #1
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)
Avatar billede blolsen Juniormester
08. marts 2017 - 16:27 #2
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
Avatar billede Jan Hansen Ekspert
08. marts 2017 - 17:44 #3
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
Avatar billede Jan Hansen Ekspert
09. marts 2017 - 14:45 #4
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
Avatar billede blolsen Juniormester
09. marts 2017 - 16:22 #5
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
Avatar billede Jan Hansen Ekspert
09. marts 2017 - 16:48 #6
Prøv bare har jeg tid svarer jeg
Avatar billede blolsen Juniormester
10. marts 2017 - 11:56 #7
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:-)
Avatar billede Jan Hansen Ekspert
10. marts 2017 - 13:27 #8
Har nok lidt tid søndag

mvh Jan
Avatar billede Jan Hansen Ekspert
10. marts 2017 - 14:35 #9
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
Avatar billede blolsen Juniormester
10. marts 2017 - 15:35 #10
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:-)
Avatar billede Jan Hansen Ekspert
12. marts 2017 - 10:40 #11
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
Avatar billede blolsen Juniormester
12. marts 2017 - 21:21 #12
Hej jan det er super - så har jeg et godt grundlag for mit videre arbejde - rigtig mange tak for hjælpen:-)
Avatar billede Jan Hansen Ekspert
13. marts 2017 - 14:47 #13
velbekomme
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester