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