Søg i hele projektmappen

Private Function søgVare(knr)
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet 'NY
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In ActiveWorkbook.Worksheets 'NY
            Sh.Activate ' NY
            Range("A1").Select ' NY
            kildeRækker = ActiveCell.SpecialCells(xlLastCell).Row

            For r = 11 To kildeRækker
                If knr = .Cells(r, 1) Then
                    søgVare = .Cells(r, 2)
                    lukObject
                    Exit Function
                End If

            Next r
        End With
    Next ' NY
    lukObject
    søgVare = ""
End Function

skal der ikke være en ' foran lukObject

Den laver fejl ved:

"End With"

lukObject ser sådan ud, den glemte jeg at vise dig:

Private Sub lukObject()
    With kXLS
        .ActiveWorkbook.Close
        .Application.Quit
    End With
    Set kXLS = Nothing
End Sub

Private Function søgVare(knr)
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet 'NY
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In ActiveWorkbook.Worksheets 'NY
            Sh.Activate ' NY
            Range("A1").Select ' NY
            kildeRækker = ActiveCell.SpecialCells(xlLastCell).Row

            For r = 11 To kildeRækker
                If knr = .Cells(r, 1) Then
                    søgVare = .Cells(r, 2)
                    lukObject
                    Exit Function
                End If

            Next r
        Next ' NY
        End With
    lukObject
    søgVare = ""
End Function

Når jeg taster et varenr. i celle A17 (det er denne værdi den skal søge efter i min kildefil i kolonne A på alle ark)

Så kommer den med en dialogboks som spørger om jeg vil gemme ændringerne i min kildefil ?

Hvis jeg svarer ja eller nej kommer den med en fejl om at den ikke kan finde varenr. (jeg ved det findes)

Vi prøver at aktivere en anden celle, jeg kan se at du starter i række 11

Private Function søgVare(knr)
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet 'NY
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In ActiveWorkbook.Worksheets 'NY
            Sh.Activate ' NY
            Range("A11").Select ' NY
            kildeRækker = ActiveCell.SpecialCells(xlLastCell).Row

            For r = 11 To kildeRækker
                If knr = .Cells(r, 1) Then
                    søgVare = .Cells(r, 2)
                    lukObject
                    Exit Function
                End If

            Next r
        Next ' NY
        End With
    lukObject
    søgVare = ""
End Function

Det virker heller ikke, samme fejl

P.S. Nu starter det på række 1 som først antaget.

Nu testede jeg lige igen.

Den henter de rigtige værdier til de rigtige celler nu efter jeg har annulleret dialogboksen.

Men den kommer stadig med dialogboksen til at starte med

Og den kan kun hente data fra det første ark i kildefilen...

Private Function søgVare(knr)
    Dim Sh As Worksheet 'NY
          Workbooks.Open kildeSti
        For Each Sh In ActiveWorkbook.Worksheets 'NY
            Sh.Activate ' NY
            Range("A11").Select ' NY
            kildeRækker = ActiveCell.SpecialCells(xlLastCell).Row

            For r = 11 To kildeRækker
                If knr = Cells(r, 1) Then
                    søgVare = Cells(r, 2)
                    lukObject
                    Exit Function
                End If

            Next r
        Next ' NY
    lukObject
    søgVare = ""
End Function


Private Sub lukObject()
      Workbooks("Data.xls").Close
        'Application.Quit
End Sub

Det bliver næsten endnu værre.

Nu åbner den simpelthen kildefilen og fejler herefter på denne linie:

Range("A1").Select ' NY

ok, denne er testet

Private Function søgVare(knr)
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet    'NY
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In .Worksheets    'NY
        With Sh
            .Activate    ' NY
            kildeRækker = .Range("A65536").End(xlUp).Row

            For r = 1 To kildeRækker
                If knr = .Cells(r, 1) Then
                    søgVare = .Cells(r, 2)
                  lukObject
                    Exit Function
                End If

            Next r
            End With
        Next    ' NY
    End With
    lukObject
    søgVare = ""
End Function

Private Sub lukObject()
    With kXLS
        .ActiveWorkbook.Close
        .Application.Quit
    End With
    Set kXLS = Nothing
End Sub

Næsten samme problem som før nævnt.

Den kommer med en dialogboks som det første som spørger om jeg vil gemme ændringer i min kildefil.

Svarer jeg ja eller nej så finder den rigtigt nok oplysningerne og smider dem i mit destinationsark.

Den kan dog godt finde oplysningerne på alle ark i kildefilen nu...

Undskyld undskyld undskyld

Min fejl. Jeg havde ikke opdaget at der var en fejl i kildefilen vedr. redundans. Når denne er fjernet virker det perfekt.

Tusind tak for hjælpen. Point til dig.

Lige et bonus spørgsmål.
Koden er sådan at når jeg sletter indformationen i destinationsarkets celle A16:A56 så sletter den også værdien i cellerne til højre for som jeg har hentet.
Det virker sådan set også fint nok. Men:

1. Hvorfor tænker den så lang tid efter jeg har slette værdien i A (timeglas i 5-10 sekunder)

2. Hvis jeg markerer flere celler på en gang i kolonne A for at slette informationen så fejler den på denne linie...If Len(Target) > 0 Then

Kan du lure det problem hvis du har tid...

Private Sub worksheet_change(ByVal Target As Excel.Range)
    Dim vareNavn As String
    Dim vareNavn2 As String
    If Not Intersect(Target, Range(vareNrindtastesI)) Is Nothing Then
   
        If Target.Cells.Count > 1 Then Exit Sub    ' NY tjekker om du har flere celler markeret, hvis ja køres koden ikke
       
        If Len(Target) > 0 Then
            vareNavn = søgVare(Target.Value)
            If vareNavn <> "" Then
                Cells(Target.Row, Target.Column + 1) = vareNavn
            Else
                MsgBox ("Varenr. " + CStr(Target.Value) + " kunne ikke findes!")
                Cells(Target.Row, Target.Column) = ""
                Cells(Target.Row, Target.Column + 1) = ""
            End If
        Else
            Cells(Target.Row, Target.Column) = ""
            Cells(Target.Row, Target.Column + 1) = ""
        End If

        If Len(Target) > 0 Then
            vareNavn2 = søgVare2(Target.Value)
            If vareNavn2 <> "" Then
                Cells(Target.Row, Target.Column + 5) = vareNavn2
            Else
                Cells(Target.Row, Target.Column + 5) = ""
            End If
        Else
            Cells(Target.Row, Target.Column + 5) = ""
        End If
    End If
End Sub

Men koden skal køres selvom der er flere celler markeret i A.

Den skal bare ikke brokke sig

Og desværre tænker den stadig 5-10 sekunder efter jeg sletter....

Er det fordi den skal gennemgå for mange linier.

Den behøver faktisk kun søge på de første ca. 1500 linier på hvert ark.
Vil det ikke speede både søgning og sletning op ?

Den kikker på alle rækker der er data i i kolonne A, den finder selv den sidste.
Hvorfor skal den køre, for flere celler i Target(markeringen), du skriver vel ikke flere forskellige søgekriterier på en gang.

Jo jeg skriver søgekritier i alle linier i destinationsarket fra cell A16 til A51

Så hvis jeg markere dette område (kolonne A) så fejler den

ja, men du skriver vel kun i en af gangen, når du så skifter til næste celle, så kører koden jo automatisk.

Hvad skal den da gøre når du markere hele området, slette, eller ??.

Jeg skriver kun en af gangen og så skifter jeg til næste celle osv. når den skal søge.

Men hvis jeg vil slette alle de linier jeg har lavet (f.eks. har jeg måske skrevet noget på 10 linier) så markerer jeg fra A16 til A25 og trykker delete.

Så den skal slette hele området når jeg markerer enten kun kolonne A16 til A25 eller A16 til F25 (altså hele dataområdet)

Private Sub worksheet_change(ByVal Target As Excel.Range)
    Dim vareNavn As String
    Dim vareNavn2 As String
    Dim C As Range
    If Not Intersect(Target, Range(vareNrindtastesI)) Is Nothing Then
    Application.EnableEvents = False
  Application.ScreenUpdating = False
        For Each C In Target.Cells
        If Len(C) > 0 Then
            vareNavn = søgVare(C.Value)
            If vareNavn <> "" Then
                Cells(C.Row, C.Column + 1) = vareNavn
            Else
                MsgBox ("Varenr. " + CStr(C.Value) + " kunne ikke findes!")
                Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 5)) = ""
            End If
        Else
            Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 5)) = ""
        End If

        If Len(C) > 0 Then
            vareNavn2 = søgVare2(C.Value)
            If vareNavn2 <> "" Then
                Cells(C.Row, C.Column + 5) = vareNavn2
            Else
                Cells(C.Row, C.Column + 5) = ""
            End If
        Else
            Cells(C.Row, C.Column + 5) = ""
        End If
        Next
    End If
    Application.ScreenUpdating = True
      Application.EnableEvents = True
End Sub

Super super super

Mange tak for hjælpen

Kom endelig med et svar

P.S. Hvor lang tid tager det hos dig at hente data fra kildefilen til destinationsfilen. Det tager nemlig ca. 10 sekunder her. Kildefilen er nemlig ikke så stor, ca. 10 ark med max. 150 linier pr. ark ?

jeg kan måske gøre det hurtigere, hvis du også viser mig din "søgVare2" funktion, hvis den søger i samme som "søgVare", kan man tage i et hug, måske kan vi tage data fra kildefilen, over i et array, det vil gøre den meget hurtigere.

Kildefilen vil blive opdateret løbende og udvidet med nye ark og linier. Men altid med samme kolonne overskrifter m.v.
Kildefilen er en jeg modtager fra en anden person.

Her er min SøgVare2-funktion.
Jeg skal i princippet bruge et par funktioner mere der henter data fra kildefilen over i destinationsfilen. Og dette var den eneste måde jeg kunne finde ud af at lave det på.




Private Function søgVare2(knr)
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet    'NY
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In .Worksheets    'NY
        With Sh
            .Activate    ' NY
            kildeRækker = .Range("A65536").End(xlUp).Row

            For r = 1 To kildeRækker
                If knr = .Cells(r, 1) Then
                    søgVare2 = .Cells(r, 4)
                  lukObject
                    Exit Function
                End If

            Next r
            End With
        Next    ' NY
    End With
    lukObject
    søgVare2 = ""
End Function

Dim Data() As Variant
Const kildeSti = "H:\Data.xls"
Dim kXLS, kildeRækker, Rækker As Integer
Dim RW As Long
Const vareNrindtastesI = "A16:A51"


Private Sub worksheet_change(ByVal Target As Excel.Range)
    Dim vareNavn As String
    Dim vareNavn2 As String
    Dim C As Range, I As Long
    Dim Fundet As Boolean
    If Not Intersect(Target, Range(vareNrindtastesI)) Is Nothing Then
        If RW = 0 Then HentData    ' tjekker om data er indlæst, hvis ikke hentes de
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each C In Target.Cells
            Fundet = False
            If Len(C) > 0 Then
                For I = 1 To RW
                    If Data(I, 0) = C.Value Then
                        Cells(C.Row, C.Column + 1) = Data(I, 1)
                        Cells(C.Row, C.Column + 5) = Data(RW, 4)
                        Fundet = True
                        Exit For
                    End If
                Next
                If Not Fundet Then
                    MsgBox ("Varenr. " + CStr(C.Value) + " kunne ikke findes!")
                    Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 5)) = ""
                End If
            Else
                Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 5)) = ""
            End If
        Next
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


Private Sub lukObject()
    With kXLS
        .ActiveWorkbook.Close
        .Application.Quit
    End With
    Set kXLS = Nothing
End Sub
Private Function HentData()
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In .Worksheets    'NY
            With Sh
                .Activate
                kildeRækker = kildeRækker + .Range("A65536").End(xlUp).Row    ' tæller hvor mange data rækker, der er ialt
            End With
        Next
        ReDim Data(kildeRækker, 5)    ' klargør arrayet til at indeholde data, med 6 kolonner i
        RW = 0                        ' første kolonne hedder 0
        For Each Sh In .Worksheets    'NY
            Rækker = .Range("A65536").End(xlUp).Row
            With Sh
                For r = 1 To Rækker
                    RW = RW + 1
                    For I = 1 To 5
                        Data(RW, I - 1) = .Cells(r, I)  ' lægger data ind i array
                    Next
                Next
            End With
        Next
    End With
    lukObject
End Function


Public Sub StartAutomatiskeMakroer()
' kør denne makro, hvis de automatiske svigter
' det kan de gøre hvis koden går i stå imellem disse 2 linier
' Application.EnableEvents = False
' og
'  Application.EnableEvents = True

    Application.EnableEvents = True
End Sub


det var vist det du behøver, prøv at teste.

første gang du søger går det lidt tid, da den henter data først, men derefter skulle det gå hurtigt.

Den går direkte til fejlmeddelelsen at "Varenr. findes ikke" når jeg taster en værdi i kolonne A i destinationsarket....

har du husket dette

Dim Data() As Variant
Const kildeSti = "H:\Data.xls"
Dim kXLS, kildeRækker, Rækker As Integer
Dim RW As Long
Const vareNrindtastesI = "A16:A51"

Jeps

jaa, det virker fint her, prøv lige at smide al den kode ind, du har i arket nu.

Dim Data() As Variant
Const kildeSti = "H:\Data.xls"
Dim kXLS, kildeRækker, Rækker As Integer
Dim RW As Long
Const vareNrindtastesI = "A16:A51"


Private Sub worksheet_change(ByVal Target As Excel.Range)
    Dim vareNavn As String
    Dim vareNavn2 As String
    Dim C As Range, I As Long
    Dim Fundet As Boolean
    If Not Intersect(Target, Range(vareNrindtastesI)) Is Nothing Then
        If RW = 0 Then HentData    ' tjekker om data er indlæst, hvis ikke hentes de
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        For Each C In Target.Cells
            Fundet = False
            If Len(C) > 0 Then
                For I = 1 To RW
                    If Data(I, 0) = C.Value Then
                        Cells(C.Row, C.Column + 1) = Data(I, 1)
                        Cells(C.Row, C.Column + 5) = Data(RW, 4)
                        Fundet = True
                        Exit For
                    End If
                Next
                If Not Fundet Then
                    MsgBox ("Varenr. " + CStr(C.Value) + " kunne ikke findes!")
                    Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 5)) = ""
                End If
            Else
                Range(Cells(C.Row, C.Column), Cells(C.Row, C.Column + 5)) = ""
            End If
        Next
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


Private Sub lukObject()
    With kXLS
        .ActiveWorkbook.Close
        .Application.Quit
    End With
    Set kXLS = Nothing
End Sub
Private Function HentData()
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In .Worksheets    'NY
            With Sh
                .Activate
                kildeRækker = kildeRækker + .Range("A65536").End(xlUp).Row    ' tæller hvor mange data rækker, der er ialt
            End With
        Next
        ReDim Data(kildeRækker, 5)    ' klargør arrayet til at indeholde data, med 6 kolonner i
        RW = 0                        ' første kolonne hedder 0
        For Each Sh In .Worksheets    'NY
            Rækker = .Range("A65536").End(xlUp).Row
            With Sh
                For r = 1 To Rækker
                    RW = RW + 1
                    For I = 1 To 5
                        Data(RW, I - 1) = .Cells(r, I)  ' lægger data ind i array
                    Next
                Next
            End With
        Next
    End With
    lukObject
End Function


Public Sub StartAutomatiskeMakroer()
' kør denne makro, hvis de automatiske svigter
' det kan de gøre hvis koden går i stå imellem disse 2 linier
' Application.EnableEvents = False
' og
'  Application.EnableEvents = True

    Application.EnableEvents = True
End Sub

virker fint her

du har ikke en variabel et andet sted der hedder RW ??

ret
                  If Data(I, 0) = C.Value Then
                        Cells(C.Row, C.Column + 1) = Data(I, 1)
                        Cells(C.Row, C.Column + 5) = Data(RW, 4)
                        Fundet = True
                        Exit For
                    End If
     

til
                  If Data(I, 0) = C.Value Then
                        Cells(C.Row, C.Column + 1) = Data(I, 1)
                        Cells(C.Row, C.Column + 5) = Data(I, 4)
                        Fundet = True
                        Exit For
                    End If
     

men det er ikke den fejl vi søger

Nej det er den eneste kode jeg har i det ark

Så har jeg en userform - men der er ikke nogen variabel som hedder rw

Hvis jeg ændrer stien til kildearket skal jeg kun rette det på denne linie ikke ?

Const kildeSti = "H:\Data.xls"

prøv at sende både datamappen og din resultatmappe til mig, så kan jeg måske se fejlen.
jeg skal i byen om en time, så måske bliver det først i morgen

kabbak snabela tiscali dot dk

ja til dit spørgsmål

Super

Jeg har sendt dem nu...

Private Function HentData()
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In .Worksheets    'NY
            With Sh
                .Activate
                kildeRækker = kildeRækker + .Range("A65536").End(xlUp).Row    ' tæller hvor mange data rækker, der er ialt
            End With
        Next
        ReDim Data(kildeRækker, 5)    ' klargør arrayet til at indeholde data, med 6 kolonner i
        RW = 0                        ' første kolonne hedder 0
        For Each Sh In .Worksheets
        With Sh
            Rækker = .Range("A65536").End(xlUp).Row
         
                For r = 1 To Rækker
                    RW = RW + 1
                    For I = 1 To 5
                        Data(RW, I - 1) = .Cells(r, I)  ' lægger data ind i array
                    Next
                Next
            End With
        Next
    End With
    lukObject
End Function

der var en fejl i denne function, mon ikke den virker nu

Genialt

Det virker perfekt og går meget hurtigere.

Jeg bukker og takker for hjælpen og tålmodigheden.

ingen årsag, tak for point ;-))

Jeg fik din mail, men jeg kunne ikke svare, jeg fik "Delivery to the following recipients failed."

jeg har nu tunet denne del lidt op, prøv at teste.


Private Function HentData()
    Set kXLS = CreateObject("Excel.application")
    Dim Sh As Worksheet
    Dim Temp As Variant
    With kXLS
        .Workbooks.Open kildeSti
        For Each Sh In .Worksheets    'NY
            With Sh
                .Activate
                kildeRækker = kildeRækker + .Range("A65536").End(xlUp).Row    ' tæller hvor mange data rækker, der er ialt
            End With
        Next
        ReDim Data(kildeRækker, 5)    ' klargør arrayet til at indeholde data, med 6 kolonner i
        RW = 0                        ' første kolonne hedder 0
        For Each Sh In .Worksheets
        With Sh
            Rækker = .Range("A65536").End(xlUp).Row
            Temp = .Range("A1:E" & Rækker)
                For R = 1 To Rækker
                If IsNumeric(Temp(R, 1)) Then
                    RW = RW + 1
                    For I = 1 To 5
                        Data(RW, I - 1) = Temp(R, I) ' lægger data ind i array
                    Next
                    End If
                Next
            End With
        Next
    End With
    lukObject
End Function

Hej kabbak

Jeg ved ikke lige hvad der er sket med min mail. Jeg har dog modtaget dine beskeder nu (søndag).

Jeg har implementeret din kode og synes den løber væsentligt hurtigere.

Tusind tak for hjælpen.

Hej kabbak

Nu har jeg lavet 15 ark i en Excelfil med ovenstående kode på hvert ark

Det går sådan set fint hastighedsmæssigt hver gang jeg skal hente data på det enkelte ark.

Men Excel tænker voldsomt hver gang jeg skifter mellem arkene. Jo flere ark jo længere tid er Excel også om at åbne filen ?

Kan du hjælpe ?

Mener du skifte imellem arkene i den mappe, som koden står i, koden har ikke noget at gøre med, at du skifter ark, det må være noget andet.
Koden skal jo kun køres 1 gang, når du åbner mappen.

Har du nogen automatiske makroer, der kører, når du skifter side

som f.eks.
Private Sub worksheet_change(ByVal Target As Excel.Range)

Så har jeg nok misforstået noget

Koden ligger på alle ark sammen med Private Sub worksheet_change(ByVal Target As Excel.Range)

Se ovenstående 16:02:26

Og den virker fint på arkene, men sløves mere og mere ned jo flere ark.

prøv at sende den til mig

kabbak snabela tiscali dot dk

Rettet og retuneret