Langsom makro

SpecialCells(xlLastCell) kan være problemet.
Den sidste celle er nemlig ikke nulstillet engang imellem og gå også efter formater, ikke kun tal.

Prøv at erstatte de 3
Max = .ActiveCell.SpecialCells(xlLastCell).Row

med henholdvis

Max = .ActiveSheet.Range("A65536").End(xlUp).Row
Max = .ActiveSheet.Range("B65536").End(xlUp).Row
Max = .ActiveSheet.Range("C65536").End(xlUp).Row

Dertil skal også lige siges at indlæsningen af data heller ikke forgår på nemmeste måde.
Endvidere speeder det ikke op at man rent faktisk åbner og lukker en hel excel 3 gange i løbet af makroen.
men prøv lige først at rette det andet.

Det ser ikke ud til at have nogen indflydelse.

Ca. 3 minutter tog det førend userformen kom frem.

Prøv lige køre denne. Her er automatisk calculation slået fra.

Hvor mange rækker er det, der skal indlæses ?
Bruges systemet til andet end excel ?

Private Sub UserForm_activate()
    indlæsÅrstal
    indlæsOpgave
    indlæsPeriode
    Me.f_kundeNr.SetFocus
End Sub


Private Sub indlæsÅrstal()                          'årstal forventes i kolonne 1
    On Error GoTo fejlÅrstalSti

    Set ÅrXLS = CreateObject("Excel.application")
    With ÅrXLS
        .Calculation = -4135
        .Workbooks.Open AarsTalSti
        .Sheets(1).Activate
        Max = .ActiveSheet.Range("A65536").End(xlUp).Row
        For r = 1 To Max
            Me.f_årsTal.AddItem .Cells(r, 1)
        Next r
    End With

    ÅrXLS.Quit
    Set ÅrXLS = Nothing
    Exit Sub

fejlÅrstalSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub

Private Sub indlæsOpgave()                          'Opgave forventes i kolonne 2
    On Error GoTo fejlOpgaveSti

    Set OpgaveXLS = CreateObject("Excel.application")
    With OpgaveXLS
        .Calculation = -4135
        .Workbooks.Open OpgaveSti
        .Sheets(1).Activate
        Max = .ActiveSheet.Range("B65536").End(xlUp).Row
        For r = 1 To Max
            Me.f_Opgave.AddItem .Cells(r, 2)
        Next r
    End With

    OpgaveXLS.Quit
    Set OpgaveXLS = Nothing
    Exit Sub

fejlOpgaveSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub
Private Sub indlæsPeriode()                          'Periode forventes i kolonne 3
    On Error GoTo fejlPeriodeSti

    Set PeriodeXLS = CreateObject("Excel.application")
    With PeriodeXLS
        .Calculation = -4135
        .Workbooks.Open PeriodeSti
        .Sheets(1).Activate
        Max = .ActiveSheet.Range("C65536").End(xlUp).Row
        For r = 1 To Max
            Me.f_periode.AddItem .Cells(r, 3)
        Next r
    End With

    PeriodeXLS.Quit
    Set PeriodeXLS = Nothing
    Exit Sub

fejlPeriodeSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub

Hej

Den brokker sig og kommer med beskeden "Fejl i sti t/data.xls" og når man trykker OK tænker det lige så lang tid som altid og vender så tilbager til fejlbeskeden igen og får aldrig gjort userformen aktiv.

Der er cirka 470 linier lige nu som den skal løbe igennem.

Disse linier samt alt andet er kun i Excel.

I stedet for en løkke, kunne du evt. anvende RowSource :

    Set ÅrXLS = CreateObject("Excel.application")
    With ÅrXLS
        .Workbooks.Open AarsTalSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        Me.f_årsTal.RowSource = "A1:A" & Max
    End With

her vis for filen ÅrXLS, skal anvendes i alle 3 filer

Hvis dette ikke hjælper nævneværdig, kunne du overveje at hente værdierne fra de 3 filer via formler, evt til et skjult ark.
Så kan du hente dem derfra.

Undskyld undskyld undskyld
Jeg er da en røv med ører.

Jeg har slet ikke opdaget der mangler starten af makroen. Jeg ved ikke hvor stor betydning det har, men det andet har i hvert fald ikke givet resultat:

Håber du har tålmodighed på mere :-)

Her er hele makroen:

Rem =========
Const AarsTalSti = "H:\Kunder\0_Mastere\XLA\data.xls"      'tilpasses
Const OpgaveSti = "H:\Kunder\0_Mastere\XLA\data.xls"
Const PeriodeSti = "H:\Kunder\0_Mastere\XLA\data.xls"
Const gemSomSti = "H:\Kunder\"          'tilpasses
Const KunderSti = "H:\SHEETS\SR\Klientliste.xls"        'tilpasses

Dim ÅrXLS As Object, kXLS As Object, passFlag As Boolean
Private Sub CommandButton1_Click()          'Gem
    If f_opgave = "Regnskaber" Then
    If Me.f_kundeNavn <> "" And Me.f_årsTal <> "" And Me.f_opgave <> "" Then
        udførGem
    Else
        MsgBox ("Alle felter skal udfyldes")
    End If
    Else
    If Me.f_kundeNavn <> "" And Me.f_årsTal <> "" And Me.f_opgave <> "" And Me.f_periode <> "" Then
        udførGem
    Else
        MsgBox ("Alle felter skal udfyldes")
    End If
    End If
End Sub

Private Sub f_opgave_Change()
    If f_opgave = "Bogføring" Then
        f_periode.Enabled = True
    Else
        f_periode.Enabled = False
    End If
End Sub
Private Sub udførGem()
Dim sti As String, gemMappe As String, uMappe As String

Rem check drev
    On Error GoTo sti_Fejl

    sti = gemSomSti
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
   
Rem Check om "GemMappe" i GemSomStien
    gemMappe = findGemMappe(sti, Me.f_kundeNr)
    If gemMappe = "" Then
        GoTo kundeMappeFindesIkke
    End If

Rem Check om "underMap1" (opgave) findes
    gemMappe = gemMappe + "\" + Me.f_opgave
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe
   
Rem Check om "underMap2" (årstal) findes
    gemMappe = gemMappe + "\" + Me.f_årsTal
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe
   
Rem Check om "underMap3" (periode) findes
    If f_opgave = "Regnskaber" Then
    gemMappe = gemMappe
    Else
    gemMappe = gemMappe + "\" + Me.f_periode
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe
    End If
   
Rem KundeMappe Ok - gem filen
    On Error GoTo fejlGemSti
    ActiveWorkbook.SaveAs sti + gemMappe + "\" + Me.f_kundeNr + " arbejdspapirer " + Me.f_årsTal + ".xls"

Rem Luk userform
    CommandButton2_Click                            'kan fjernes, hvis lukning ikke ønskes
    Exit Sub

opretUnderMappe:
    MkDir sti + gemMappe
    Resume Next
   
fejlGemSti:
    MsgBox ("Fejl i GemSti - sandsynligvis illegalt tegn i årstal")
    Exit Sub
   
kundeMappeFindesIkke:
    MsgBox ("KundeMappe findes ikke")
    Exit Sub
   
sti_Fejl:
    MsgBox ("Fejl i en sti-angivelse")
End Sub

Private Sub f_kundeNr_Enter()
    Me.f_kundeNavn = ""
End Sub
Private Sub f_kundeNr_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If passFlag = False Then
        passFlag = True
        If Me.f_kundeNr <> "" And IsNumeric(Me.f_kundeNr) = True Then
            Me.f_kundeNavn = søgKunde(Val(Me.f_kundeNr))
            If Me.f_kundeNavn <> "" Then
                    Me.f_opgave.SetFocus
            End If
           
            kXLS.Quit
            Set kXLS = Nothing
        End If
        passFlag = False
    End If
End Sub
Private Sub CommandButton2_Click()          'Annuller
    Unload UserForm4
End Sub

Private Sub f_årsTal_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Rem Evt. "/" erstattes af "-" - illegalt tegn

    If Me.f_årsTal <> "" Then
        p = InStr(Me.f_årsTal, "/")
        If p > 0 Then
            Me.f_årsTal = Left(Me.f_årsTal, p - 1) + "-" + Mid(Me.f_årsTal, p + 1)
        End If
    End If
End Sub
Private Function søgKunde(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open KunderSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKunde = .Cells(r, 2)
                Exit Function
            End If
        Next r
    End With
    søgKunde = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function findGemMappe(sti, kNr)
Rem Søger efter mappe med navnet: Kundenr+BLANK i begyndelsen af MappeNavnet
    Dim fs, f, f1, fc, s, xKnr
    kNr = CStr(Val(kNr))                            'fjerner foranstillede nuller
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.SubFolders
    For Each f1 In fc
        If InStr(f1.Name, kNr + " ") = 1 Or InStr(f1.Name, kNr) = 1 Then
            findGemMappe = f1.Name                  'Fulde mappeNavn returneres..
            Exit Function
        End If
    Next
    findGemMappe = ""
End Function
Private Sub UserForm_activate()
    indlæsÅrstal
    indlæsOpgave
    indlæsPeriode
    Me.f_kundeNr.SetFocus
End Sub


Private Sub indlæsÅrstal()                          'årstal forventes i kolonne 1
    On Error GoTo fejlÅrstalSti
   
    Set ÅrXLS = CreateObject("Excel.application")
    With ÅrXLS
        .Workbooks.Open AarsTalSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.f_årsTal.AddItem .Cells(r, 1)
        Next r
    End With
   
    ÅrXLS.Quit
    Set ÅrXLS = Nothing
    Exit Sub

fejlÅrstalSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub

Private Sub indlæsOpgave()                          'Opgave forventes i kolonne 2
    On Error GoTo fejlOpgaveSti
   
    Set OpgaveXLS = CreateObject("Excel.application")
    With OpgaveXLS
        .Workbooks.Open OpgaveSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.f_opgave.AddItem .Cells(r, 2)
        Next r
    End With
   
    OpgaveXLS.Quit
    Set OpgaveXLS = Nothing
    Exit Sub

fejlOpgaveSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub
Private Sub indlæsPeriode()                          'Periode forventes i kolonne 3
    On Error GoTo fejlPeriodeSti
   
    Set PeriodeXLS = CreateObject("Excel.application")
    With PeriodeXLS
        .Workbooks.Open PeriodeSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.f_periode.AddItem .Cells(r, 3)
        Next r
    End With
   
    PeriodeXLS.Quit
    Set PeriodeXLS = Nothing
    Exit Sub

fejlPeriodeSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub

okay

prøv at udskifte hele koden med dette.
De 3 sidste  subs er erstattet af en enkelt, da der kun er en fil, der skal åbnes fra start.

Option Explicit


Rem =========
Const AarsTalSti = "H:\Kunder\0_Mastere\XLA\data.xls"      'tilpasses
Const OpgaveSti = "H:\Kunder\0_Mastere\XLA\data.xls"
Const PeriodeSti = "H:\Kunder\0_Mastere\XLA\data.xls"
Const gemSomSti = "H:\Kunder\"          'tilpasses
Const KunderSti = "H:\SHEETS\SR\Klientliste.xls"        'tilpasses
Dim WB As Workbook
Dim ÅrXLS As Object, kXLS As Object, passFlag As Boolean

Private Sub CommandButton1_Click()          'Gem
    If F_opgave = "Regnskaber" Then
        If Me.f_kundeNavn <> "" And Me.F_årstal <> "" And Me.F_opgave <> "" Then
            udførGem
        Else
            MsgBox ("Alle felter skal udfyldes")
        End If
    Else
        If Me.f_kundeNavn <> "" And Me.F_årstal <> "" And Me.F_opgave <> "" And Me.F_periode <> "" Then
            udførGem
        Else
            MsgBox ("Alle felter skal udfyldes")
        End If
    End If
End Sub

Private Sub f_opgave_Change()
    If F_opgave = "Bogføring" Then
        F_periode.Enabled = True
    Else
        F_periode.Enabled = False
    End If
End Sub
Private Sub udførGem()
    Dim sti As String, gemMappe As String, uMappe As String

    Rem check drev
    On Error GoTo sti_Fejl

    sti = gemSomSti
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If

    Rem Check om "GemMappe" i GemSomStien
    gemMappe = findGemMappe(sti, Me.f_kundeNr)
    If gemMappe = "" Then
        GoTo kundeMappeFindesIkke
    End If

    Rem Check om "underMap1" (opgave) findes
    gemMappe = gemMappe + "\" + Me.F_opgave
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe

    Rem Check om "underMap2" (årstal) findes
    gemMappe = gemMappe + "\" + Me.F_årstal
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe

    Rem Check om "underMap3" (periode) findes
    If F_opgave = "Regnskaber" Then
        gemMappe = gemMappe
    Else
        gemMappe = gemMappe + "\" + Me.F_periode
        On Error GoTo opretUnderMappe
        ChDir sti + gemMappe
    End If

    Rem KundeMappe Ok - gem filen
    On Error GoTo fejlGemSti
    ActiveWorkbook.SaveAs sti + gemMappe + "\" + Me.f_kundeNr + " arbejdspapirer " + Me.F_årstal + ".xls"

    Rem Luk userform
    CommandButton2_Click                            'kan fjernes, hvis lukning ikke ønskes
    Exit Sub

opretUnderMappe:
    MkDir sti + gemMappe
    Resume Next

fejlGemSti:
    MsgBox ("Fejl i GemSti - sandsynligvis illegalt tegn i årstal")
    Exit Sub

kundeMappeFindesIkke:
    MsgBox ("KundeMappe findes ikke")
    Exit Sub

sti_Fejl:
    MsgBox ("Fejl i en sti-angivelse")
End Sub

Private Sub f_kundeNr_Enter()
    Me.f_kundeNavn = ""
End Sub

Private Sub f_kundeNr_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If passFlag = False Then
        passFlag = True
        If Me.f_kundeNr <> "" And IsNumeric(Me.f_kundeNr) = True Then
            Me.f_kundeNavn = søgKunde(Val(Me.f_kundeNr))
            If Me.f_kundeNavn <> "" Then
                Me.F_opgave.SetFocus
            End If

            kXLS.Quit
            Set kXLS = Nothing
        End If
        passFlag = False
    End If
End Sub

Private Sub CommandButton2_Click()          'Annuller
    Unload UserForm4
End Sub

Private Sub f_årsTal_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Rem Evt. "/" erstattes af "-" - illegalt tegn

    If Me.F_årstal <> "" Then
        p = InStr(Me.F_årstal, "/")
        If p > 0 Then
            Me.F_årstal = Left(Me.F_årstal, p - 1) + "-" + Mid(Me.F_årstal, p + 1)
        End If
    End If
End Sub

Private Function søgKunde(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open KunderSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKunde = .Cells(r, 2)
                Exit Function
            End If
        Next r
    End With
    søgKunde = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function

Private Function findGemMappe(sti, kNr)
Rem Søger efter mappe med navnet: Kundenr+BLANK i begyndelsen af MappeNavnet
    Dim fs, f, f1, fc, s, xKnr
    kNr = CStr(Val(kNr))                            'fjerner foranstillede nuller

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.SubFolders
    For Each f1 In fc
        If InStr(f1.Name, kNr + " ") = 1 Or InStr(f1.Name, kNr) = 1 Then
            findGemMappe = f1.Name                  'Fulde mappeNavn returneres..
            Exit Function
        End If
    Next
    findGemMappe = ""
   
End Function

Private Sub UserForm_activate()
    On Error GoTo errhandler
    Set WB = Workbooks.Open(OpgaveSti)
    GetData
    WB.Close savechanges:=False
    '    indlæsÅrstal
    '    indlæsOpgave
    '    indlæsPeriode
    Me.f_kundeNr.SetFocus
    Exit Sub
errhandler:
    MsgBox "Fejl i stien"
End Sub

Private Sub GetData()
    Dim wsh As Worksheet
    Dim lX As Long
    Dim v As Variant
    Set wsh = WB.Sheets(1)
    With wsh
        v = .Range("A1:A" & .Range("A65536").End(xlUp).Row)
        Me.F_årstal.List = v
        v = .Range("B1:B" & .Range("B65536").End(xlUp).Row)
        Me.F_opgave = v
        v = .Range("C1:C" & .Range("C65536").End(xlUp).Row)
        Me.F_periode = v
    End With
End Sub

Private Sub indlæsÅrstal()                          'årstal forventes i kolonne 1

    On Error GoTo fejlÅrstalSti

    Set ÅrXLS = CreateObject("Excel.application")
    With ÅrXLS
        .Workbooks.Open AarsTalSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.F_årstal.AddItem .Cells(r, 1)
        Next r
    End With

    ÅrXLS.Quit
    Set ÅrXLS = Nothing
    Exit Sub

fejlÅrstalSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub

Private Sub indlæsOpgave()                          'Opgave forventes i kolonne 2
    On Error GoTo fejlOpgaveSti

    Set OpgaveXLS = CreateObject("Excel.application")
    With OpgaveXLS
        .Workbooks.Open OpgaveSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.F_opgave.AddItem .Cells(r, 2)
        Next r
    End With

    OpgaveXLS.Quit
    Set OpgaveXLS = Nothing
    Exit Sub

fejlOpgaveSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub
Private Sub indlæsPeriode()                          'Periode forventes i kolonne 3
    On Error GoTo fejlPeriodeSti

    Set PeriodeXLS = CreateObject("Excel.application")
    With PeriodeXLS
        .Workbooks.Open PeriodeSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.F_periode.AddItem .Cells(r, 3)
        Next r
    End With

    PeriodeXLS.Quit
    Set PeriodeXLS = Nothing
    Exit Sub

fejlPeriodeSti:
    MsgBox ("Fejl i sti t/data.xls")
End Sub

Det virker desværre heller ikke.

Nu åbner den min datafil i baggrunden og skriver stadig som det første en fejlmeddelelse i userformen.

Hvis du kan så send både xla'en og datafilen, så skal jeg se hvad der er galt.
tommybak snabela gmail.com