Avatar billede HHA Guru
30. oktober 2020 - 13:12 Der er 1 løsning

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
Avatar billede HHA Guru
22. juni 2021 - 20:11 #1
Lukker dette spørgsmål, da det er til gene for andre at det er åbent.
Løst eller ej.
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
Excel-kurser for alle niveauer og behov – find det kursus, der passer til dig

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