HHA Juniormester
30. oktober 2020 - 13:12

Oprette rulleliste til at vælge hvor og hvad den skal hente

Hejsa,

Jeg sidder og roder med at få lavet en rulleliste, hvor man kan vælge forskellige excel filer, som den skal hente indholdet fra.
Indtil nu har vi kun haft en fil, men ønsker at kunne hente flere forskellige.

Tænkte på en rulleliste, hvor man vælger den man vil hente over i den åbne fil.
Men hvordan laver jeg en rulleliste, som henter det valgte over, lige som den makro nedefor, som dog kun kan hente en fil over?

Sub OpdaterStandardpriser()

'On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Worksheets("Standardpriser").Unprotect
    Dim src As Workbook
    Set ws1 = Sheets("Standardpriser")
    ws1.Range("B20:B" & Rows.Count).ClearContents
    ws1.Range("C20:C" & Rows.Count).ClearContents
    ws1.Range("D20:D" & Rows.Count).ClearContents
    ws1.Range("E20:E" & Rows.Count).ClearContents
    ws1.Range("F20:F" & Rows.Count).ClearContents
    ws1.Range("G20:G" & Rows.Count).ClearContents
    ws1.Range("H20:H" & Rows.Count).ClearContents
    ws1.Range("I20:I" & Rows.Count).ClearContents
    ws1.Range("J20:J" & Rows.Count).ClearContents
    ws1.Range("K20:K" & Rows.Count).ClearContents
    ws1.Range("K20:L" & Rows.Count).ClearContents
    ws1.Range("M20:M" & Rows.Count).ClearContents
    ws1.Cells.Borders.LineStyle = xlLineStyleNone
   
    ' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
    Set src = Workbooks.Open("J:\Salg\Tilbud\Morten\Standardpriser.xlsm", True, True)
   
    ' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
    Dim iTotalRows As Integer
    iTotalRows = src.Sheets("Kalk").Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Rows.Count
 
    ' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
    Dim iCnt As Integer        ' COUNTER.
    For iCnt = 20 To iTotalRows
    ws1.Cells(iCnt, "A").Value = "Nej"
       
       
    With ws1.Cells(iCnt, "A").Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=$A$18:$A$19"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
   
       
        ws1.Cells(iCnt, "B").Value = 1
        ws1.Cells(iCnt, "C").Value = src.Worksheets("Kalk").Cells(iCnt, "D").Value
        ws1.Cells(iCnt, "C").BorderAround xlContinuous
           
            If src.Worksheets("Kalk").Cells(iCnt, "B") = "JA" Then ' Laver overskrifter gule, hvis kilden siger at det er en overskrift
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 6
                ws1.Cells(iCnt, "B").Value = ""
            ElseIf ws1.Cells(iCnt, "C") = "" Then
                ws1.Cells(iCnt, "B") = ""
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
            Else
                ws1.Cells(iCnt, "C").Interior.ColorIndex = 2
            End If
          ' If src.Worksheets("Kalk").Cells(iCnt, "B") = "NEJ" Then ' Laver celler hvid, hvis kilden siger at det ikke er en overskrift
         
                     
        ws1.Cells(iCnt, "D").Value = src.Worksheets("Kalk").Cells(iCnt, "E").Value
        ws1.Cells(iCnt, "D").BorderAround xlContinuous
        ws1.Cells(iCnt, "E").Value = src.Worksheets("Kalk").Cells(iCnt, "F").Value
        ws1.Cells(iCnt, "E").BorderAround xlContinuous
        ws1.Cells(iCnt, "F").Value = src.Worksheets("Kalk").Cells(iCnt, "I").Value
        ws1.Cells(iCnt, "F").BorderAround xlContinuous
        ws1.Cells(iCnt, "G").Value = src.Worksheets("Kalk").Cells(iCnt, "J").Value
        ws1.Cells(iCnt, "G").BorderAround xlContinuous
        ws1.Cells(iCnt, "H").Value = src.Worksheets("Kalk").Cells(iCnt, "K").Value
        ws1.Cells(iCnt, "H").BorderAround xlContinuous
        ws1.Cells(iCnt, "I").Value = src.Worksheets("Kalk").Cells(iCnt, "L").Value
        ws1.Cells(iCnt, "I").BorderAround xlContinuous
        ws1.Cells(iCnt, "J").Value = src.Worksheets("Kalk").Cells(iCnt, "A").Value
        ws1.Cells(iCnt, "J").BorderAround xlContinuous
        ws1.Cells(iCnt, "K").Value = src.Worksheets("Kalk").Cells(iCnt, "C").Value
        ws1.Cells(iCnt, "K").BorderAround xlContinuous
        ws1.Cells(iCnt, "L").Value = src.Worksheets("Kalk").Cells(iCnt, "M").Value
        ws1.Cells(iCnt, "L").BorderAround xlContinuous
        ws1.Cells(iCnt, "M").Value = src.Worksheets("Kalk").Cells(iCnt, "U").Value
        ws1.Cells(iCnt, "M").BorderAround xlContinuous
        ws1.Cells(iCnt, "A").BorderAround xlContinuous
        ws1.Cells(iCnt, "B").BorderAround xlContinuous
    Next iCnt
   
    ' CLOSE THE SOURCE FILE.
    src.Close False            ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing
   
    Application.ScreenUpdating = True
    Worksheets("Standardpriser").Protect
    EnableSelection = xlNoRestrictions
   
ErrHandler:
   
    'src.Close False      ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Worksheets("Standardpriser").Protect
    EnableSelection = xlNoRestrictions
   
   
End Sub

Sub tilbage_til_kalk()
' tilbage_til_kalk Makro
'

'
Sheets("Kalk").Select ' tilbage til kalk

End Sub
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

Opret Preview

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





Premium
Grundfos fyrer to-cifret antal it-medarbejdere i stor omstrukturering
Den store fyringsrunde i Grundfos i september har fået konsekvenser for selskabets it-afdeling, der bliver beskåret. Et to-cifret antal it-medarbejdere er blevet opsagt.
Computerworld
Stein Bagger gør comeback i ny branche: "De lignede et mafiahold, førte sig frem som nyrige og plaprede løs om urealistiske drømme"
Stein Bagger har skiftet navn og fører sig nu frem i store biler i en helt ny branche, skriver en dansk avis.
CIO
Podcast: Her er seks gode råd om ledelse og digitalisering fra danske top-CIO'er
The Digital Edge: Vi har talt med 17 af Danmarks dygtigste digitale ledere - og samlet deres seks bedste råd om digitalisering og ledelse. Få alle rådene på 26 minutter i denne episode af podcasten The Digital Edge.
Job & Karriere
Se Waoos forklaring: Derfor har selskabet fyret topchef Jørgen Stensgaard med omgående virkning
Waaos bestyrelse opsiger fiberselskabets topchef, Jørgen Stensgaard, der fratræder med omgående virkning. Se hele forklaringen fra Waao her.
White paper
Kunsten at navigere i en tilpasningsøkonomi
Evnen til at tilpasse sig en verden i konstant forandring bliver afgørende for virksomhedens mulighed for at vækste i fremtiden. Ét af de finansielle håndtag du kan skrue på, er en hel eller delvis outsourcing af it-driften. I e-bogen ”Kunsten at navigere i en tilpasningsøkonomi” får du viden om, hvordan din virksomhed kan bruge tilpasningsøkonomi til at håndtere fremtidens krav til it. Vi spørger blandt andet: - Kan din virksomhed skalere og tilpasse sin digitale kapacitet og økonomi? - Har dine kunder tillid til, at du har de skarpeste it-løsninger? - Ville I kunne styrke forretningen ved at give jeres it mere fokus? - Kan I få øget funktionalitet til samme pris? Vi fokuserer på risiko, økonomi, fokus og valg af it-partner, som er fire opmærksomhedspunkter du skal have styr på for at lykkes med at tilpasse virksomheden til at modstå forandringerne i verden.