Sortering i delte mapper

Kan du ikke sætte en tom kolonne ind mellem I og J, for derefter at skjule den.

sorteringen plejer ikke at hoppe over tomme kolonner.

Det ved jeg da ikke - men jeg prøver lige.

Desværre - den ignorer slet og ret den tomme kolonne :0(

så ved jeg ikke, jeg har faktisk aldrig arbejdet med delte mapper.

Øv - jeg blev ellers lidt opløftet over at du kiggede på det. De forbandede delte mapper giver ofte problemer. Man tak for forsøget.

Jeg har ingen umiddelbar løsning, men nogle ting virker bare ikke i delte mapper.
Har selv har koder, der bare ikke ville køre som normalt når mappen er delt :-(

Altså når ingen af JER kan løse det så er der måske ingen løsning af finde?

Når man kigger i bøgerne Excel 2002 bible/formulas så nævnes deling med 2 ord (i ved overdrivelse fremmer forståelsen).

Yes, ved det godt. Her er kun tilbage at eksperimentere selv :-)
Så er det selvfølgelig noget snask at man hele tiden skal skifte mellem delt / udelt, fordi man ikke kan komme til koden i delt tilstand.

Vis lige din sorteringkode

Sub FindEfterlysteDyr()
Application.ScreenUpdating = False
Dim Data As Variant ' NY
Sheets("Resultat").Activate
Range("A2:H100").Select
Selection.ClearContents
UserForm1.ListBox1.Clear  ' NY
Dim Søg As String, twb As Workbook
Set twb = ThisWorkbook
Søg = InputBox("Indtast søgetekst")
If Søg <> "" Then
With Sheets("Efterlyste dyr").Range("D3:E1000")
Call SorterEfterlyste

    Set S = .Find(Søg, LookIn:=xlValues)
    If Not S Is Nothing Then
        firstAddress = S.Address
        Do
 
                      Set S = .FindNext(S)
         
            If Left(S.Address, 2) = "$D" Then
                With Sheets("Resultat").Range("A65536").End(xlUp)
                .Offset(1, 1) = S.Value
                .Offset(1, 0) = S.Offset(0, -3).Value
                .Offset(1, 2) = S.Offset(0, 1).Value
                .Offset(1, 3) = S.Offset(0, 2).Value
                .Offset(1, 4) = S.Offset(0, 3).Value
                .Offset(1, 5) = S.Offset(0, 4).Value
                .Offset(1, 6) = S.Offset(0, 5).Value
                .Offset(1, 7) = S.Offset(0, 7).Value
                End With
       
        ElseIf Left(S.Address, 2) = "$E" Then
                With Sheets("Resultat").Range("A65536").End(xlUp)
                .Offset(1, 2) = S.Value
                .Offset(1, 1) = S.Offset(0, -1).Value
                .Offset(1, 0) = S.Offset(0, -4).Value
                .Offset(1, 3) = S.Offset(0, 1).Value
                .Offset(1, 4) = S.Offset(0, 2).Value
                .Offset(1, 5) = S.Offset(0, 3).Value
                .Offset(1, 6) = S.Offset(0, 4).Value
                .Offset(1, 7) = S.Offset(0, 6).Value
                End With
                   
            End If
         
          Loop While Not S Is Nothing And S.Address <> firstAddress
       
        Call Sorter97Resultat
        Call DeleteDuplicateRows
        A = Sheets("Resultat").Range("A65536").End(xlUp).Row 'NY
        Data = Sheets("Resultat").Range("A2:I" & A)          'NY

        Unload FrmIndsætData
       
        For x = LBound(Data, 1) To UBound(Data, 1)
            Data(x, 1) = CStr(Data(x, 1))
        Next

        UserForm1.ListBox1.List() = Data                    'NY
        UserForm1.Caption = "Søgeresultat - Efterlyste dyr"
        UserForm1.Label5.Caption = "Ejer"
        UserForm1.Label6.Caption = "Bortløbet fra"
               
        Else:
        MsgBox ("Ikke fundet")
        FrmIndsætData.Show
        Exit Sub
       
        End If
End With
Unload FrmIndsætData
UserForm1.Show ' NY

Exit Sub
Else
MsgBox ("Søgetekst skal indtastes")
FrmIndsætData.Show
End If
End Sub

Ja, den har jeg set flere gange nu, men sorteringskoden.... :-)

Call SorterEfterlyste

Ups - sorry :0(
Sub SorterEfterlyste()
Application.ScreenUpdating = False

Sheets("Efterlyste dyr").Activate
    Range("efterlyste").Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Range("A3").Select
   
End Sub

Det er egentlig betryggende at vide at skulle koden på mærkelig vis forsvinde er der jo hjælp at hente ;0)

hvordan er Range("Efterlyste") defineret ?
er det forøvrigt den sub der ikke funker eller er det den næste
Call Sorter97Resultat

A3:I1000 - det var noget jeg forsøgte for at få delingen til at fungere. Sorter97 fungerer fint for den skal ikke tage hensyn til en kolonne der ikke må sorteres. Jeg avde overvejet at smide kolonnen med numrene i kolonne a i stedet men det gør INGEN forskel. Når man vælger sorter i delt-tilstand vælger den tilsyneladende alle kolonner men kun det antal rækker hvor der er data!

Jeg ved godt at det sinker lidt, men ikke overvældende...
Prøv at kopier A3:I1000 til et tomt ark, sorter det og smid det tilbage oveni.
noget al'a
Range("efterlyste").copy destination:=Sheets("TomtArk").range("A1")
Sheets("TomtAtk").Range("A1").Sort Key1:=Sheets("TomtArk").Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets("TomtARk").Range("A1:I1000").copy destination:= Sheets("Efterlyste dyr").Range("A3")

Tyg lidt på den, nu går jeg i seng :-))

Jeg prøver det - ind til videre tak for hjælpen

-->Bak det fungerer faktisk. Skide godt. Desværre bliver den lidt langsom af at skulle kopiere så meget i DELT tilstand så jeg har reduceret A3:I100 men jeg er ikke sikker på at det på sigt er nok. Istedet prøvede jeg (hurtigere):

Application.ScreenUpdating = False
Sheets("TomtArk").Range("A1:I100").ClearContents
    A = Sheets("Efterlyste dyr").Range("A65536").End(xlUp).Row 'NY
    B = Sheets("TomtArk").Range("A65536").End(xlUp).Row
Sheets("Efterlyste dyr").Range("A3:I" & A).Copy Destination:=Sheets("TomtArk").Range("A1")
Sheets("TomtArk").Range("A1:I1" & B).Sort Key1:=Sheets("TomtArk").Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Sheets("TomtArk").Range("A1:I" & B).Copy Destination:=Sheets("Efterlyste dyr").Range("A3")
Range("A3").Select

Men der går et eller andet galt idet den kopiere den sidst indsatte række igen og uden at den er sorteret. Kan du se hvad der er galt med koden?
Tak for hjælpen - gider du svare så får du point :0)

Altså afgive et svar IKKE nødvendigvis svare på det jeg lige har spurgt om - dumt formuleret.

Ok her er så et svar, Steen.

Her er lidt kod jeg kom til at lave. test lige den.
Opretter et ny ark til sortering og sletter det igen efter brug.

Sub test()
Dim TomtArk As Worksheet, shCopySheet As Worksheet
Dim rgCopyArea As Range, rgPasteArea As Range

Application.ScreenUpdating = False
Set TomtArk = Worksheets.Add
Set shCopySheet = Sheets("Efterlyste dyr")
Set rgCopyArea = shCopySheet.Range("A3", shCopySheet.Range("I65536").End(xlUp))
rgCopyArea.Copy Destination:=TomtArk.Range("a1")
Set rgPasteArea = TomtArk.Range("A1", TomtArk.Range("I65536").End(xlUp))
rgPasteArea.Sort Key1:=TomtArk.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
rgPasteArea.Copy Destination:=shCopySheet.Range("A3")
Application.DisplayAlerts = False
TomtArk.Delete
Application.DisplayAlerts = True
End Sub

Med en test på ca. 2000 rækker går det så hurtigt, at jeg ikke kan nå at se den arbejder. (1500 mhz)
Dette vil muligvis ændre sig når jeg prøver min egen 600 mhz maskine :-)

Det kørte fantastisk hurtigt og godt indtil jeg delte mappen. Den kan åbenbart ikke slette et sheet i delt tilstand.
Hvorfor kører den egentlig så hurtigt?

tjah, i bund og grund skal den jo jun lave tre hurtige operationer, 2 kopier og en sorter.
Jeg har lige prøvet med en delt version, det er absolut ikke hurtigt :-(

Nu har jeg blot oprettet et skjult ark TomtArk der er skjult og ikke slettes og det fungerer tilsyneladende godt og er da rimelig hurtigt. Men hvor kunne delingen dog trænge til kærlig Microsofthånd.
Tak for hjælpen - bak.

Velbekomme, Steen. Ja, deling kunne godt trænge til lidt opfriskning :-)

Faktisk har jeg lige fundet ud af at hvis man gemmer mellem hver gang man kører denne makro, kan den holde et fornuftigt tempo. (ubder 1 sek)
Hvis man glemmer at gemme bliver det til 280 sek men fuld CPU-belastning.
Denne bruger også et tomt ark, og burde måske være hurtigere endnu

Sub test3()
Dim TomtArk As Worksheet, shCopySheet As Worksheet
Dim rgCopyArea As Range, rgPasteArea As Range
Set TomtArk = Worksheets("TomtArk")
Set shCopySheet = Sheets("Efterlyste dyr")
Set rgCopyArea = shCopySheet.Range("A3", shCopySheet.Range("I65536").End(xlUp))
Set rgPasteArea = TomtArk.Range(rgCopyArea.Address)
Application.ScreenUpdating = False

rgPasteArea.Value = rgCopyArea.Value
rgPasteArea.Sort Key1:=TomtArk.Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
rgCopyArea.Value = rgPasteArea.Value

End Sub

Hej bak
Der skal lige en sletteprocedure i toppen af sub'en ellers vil den kode der er anbragt i Worksheet_Change bevirke at man ikke slette en linie jvf:

Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False
Dim Trange As Range
Dim C As Range
Set Trange = Range("A3: A1000")
'slå alle events fra da vi her henter nye data og den ellers vil køre igen.
Application.EnableEvents = False

On Error GoTo Slut

'check om den indtastede celle er i Trange
If Not Intersect(Target, Trange) Is Nothing Then
'Hvis cellen ikke er tom (blevet slettet)

    If Len(Target.Value) = 0 Then
    'Target.EntireRow.ClearContents
            Dim Msg, Style, Title, Ctxt, Response, MyString
            Msg = "Ønsker du at slette rækken?" ' Define message.
            Style = vbYesNo + vbDefaultButton2 ' Define buttons.
            Title = "Meddelelsesbox" ' Define title.
            Response = MsgBox(Msg, Style, Title)
           
            If Response = vbYes Then
            Target.Offset(0, 1).ClearContents
            Target.Offset(0, 2).ClearContents
            Target.Offset(0, 3).ClearContents
            Target.Offset(0, 4).ClearContents
            Target.Offset(0, 5).ClearContents
            Target.Offset(0, 6).ClearContents
            Target.Offset(0, 7).ClearContents
            Target.Offset(0, 8).ClearContents
          ' Call SorterEfterlyste
            Else
            Target = BeforeVal 'NY Indsætter den gamle værdi igen
            End If

    End If

End If
Application.EnableEvents = True
Exit Sub

'slå events til igen
Slut:
Application.EnableEvents = True
'MsgBox ("Fejl fundet")
End Sub

Jeg havde egentlig blot skrevet (TomtArk): Range("A1:I200").Clearcontent men hvis man istedet kunne anvende Range("I65536").End(XlUp) ville det vel være bedre - kan du hurtigt klare det (dumt spørgsmål)?

bak den sidste kode har rodet en del rundt i datoformatet så de returneres til primærarket i Non-sio tilstand. Hvad kan man gøre ved det?

Nå pyt jeg har anvendt den forrige kode jvf nedstående - jeg ved ikke helt hvorfor det med datoformatet opstod. Jeg kunne desværre ikke løse det.

Dim TomtArk As Worksheet, shCopySheet As Worksheet
Dim rgCopyArea As Range, rgPasteArea As Range
Sheets("TomtArk").Range("A1", Sheets("TomtArk").Range("I65536").End(xlUp)).ClearContents
Application.ScreenUpdating = False
Set TomtArk = Worksheets("TomtArk")
Set shCopySheet = Sheets("Efterlyste dyr")
Set rgCopyArea = shCopySheet.Range("A3", shCopySheet.Range("I65536").End(xlUp))
rgCopyArea.Copy Destination:=TomtArk.Range("a1")
Set rgPasteArea = TomtArk.Range("A1", TomtArk.Range("I65536").End(xlUp))
rgPasteArea.Sort Key1:=TomtArk.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
rgPasteArea.Copy Destination:=shCopySheet.Range("A3")