Udtræk data i nummerinterval fra flere ark+1 betingelse

Faktisk meget ala ovenstående link (virker også på numre)
mangler så at få flere ark m.v

kikker i alle ark , minus den der hedder Forside
Husk at lavve området så stor at alle data kan være der.

Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato)
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)
    For Each Ws In Worksheets
        If Ws.Name <> "Resultat" Then
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
           
            For I = 1 To UBound(Data)
                If I = 1 Or (Data(I, A3) >= Fradato And Data(I, A3) <= tildato) Then
                    For C = 0 To Col - 1
                        Uddata(X, C) = Data(I, C + 1)
                    Next
                    X = X + 1
                End If
            Next
            For I = 1 To UBound(Uddata)
                For C = 0 To Col - 1
                    If Uddata(I, C) = 0 Then Uddata(I, C) = ""
                Next
            Next
        End If
    Next Ws
    For I = 1 To UBound(Uddata)
        For C = 0 To Col - 1
            If Uddata(I, C) = 0 Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

kaldes med

=FilterData(A1:C12;A1;F1;G1)
hvor A1:C12 er det område på alle ark der skal kikkes i, men minus arket Forside

hvor F1 er fra og G1 er til

hej kabbak, jeg prøver lige hvordan der virker
din sub fra linket virker fint dog med et lille men
i A1 står der Kodenummer,som overskrift
fra B1 starter nr. adr.
problemet er, at den ud for overskrift, skriver 0 i alle
kolonner jeg har valgt, kan du rette det? evt. droppe
overskrift, den kan jeg sætte ind manuelt?

Har indsat nyt ark 'Udtræk'
øvrige hedder 013G00, 013G10  osv...
hvordan putter jeg det ind i kaldet?

Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato)
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)
    For Each Ws In Worksheets
        If Ws.Name <> "Udtræk" Then ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
           
            For I = 1 To UBound(Data)
                If I = 1 Or (Data(I, A3) >= Fradato And Data(I, A3) <= tildato) Then
                    For C = 0 To Col - 1
                        Uddata(X, C) = Data(I, C + 1)
                    Next
                    X = X + 1
                End If
            Next
            For I = 1 To UBound(Uddata)
                For C = 0 To Col - 1
                    If Uddata(I, C) = 0 Then Uddata(I, C) = ""
                Next
            Next
        End If
    Next Ws
    For I = 1 To UBound(Uddata)
        For C = 0 To Col - 1
            If Uddata(I, C) = 0 Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

Når du har overskrifter, skal den bare begynde i række 2
=FilterData(A2:C12;A2;F1;G1)

nåå det sørger subben selv for eller hur!

ja den kikker i det område du skriver

har lidt problemer kabbak
får ikke det rigtige interval
numrene i arkene er sorteret stigende, mellem ca 30 90 rækker(nr)i de 17 ark
så skal jeg markere 1200 1400 rækker i udtræk
får 5-6 numre under laveste interval og 10 mere end højeste interval

Celle indhold i udtræk : {=FilterData(A2:H90;A2;C1;E1)}
hvor A2:H90 er udsnit fra hver ark C1 er lavest interval
og E1 er højeste

jeg kunne ikke lige finde, at der var fejl i måden at vælge på, men der var noget unødvendig kode, det er fjernet.

Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato)
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)

    For Each Ws In Worksheets

        If Ws.Name <> "Udtræk" Then    ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
            For I = 1 To UBound(Data)
                If I = 1 Or (Data(I, A3) >= Fradato And Data(I, A3) <= tildato) Then
                    For C = 0 To Col - 1
                        Uddata(X, C) = Data(I, C + 1)
                    Next
                    X = X + 1
                End If
            Next
        End If

    Next Ws

    For I = 1 To UBound(Uddata)
        For C = 0 To Col - 1
            If Uddata(I, C) = 0 Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

det er ikke fordi dine tal står som tekst, for så er 111  mindre end 20

alt står som tekst
det ser ud som om den tager det første nummer i hvet ark
og ligger ind før mit laveste interval

ja den tager det første nummer i arkene til venstre for det ark hvor
numrene jeg søger ligger i, og ligger før mit interval,
og første nr. fra arkene til højre for mit interval-ark og ligger sidst
i intervallisten (udtræk)

hvordan er dine tekster, kan du bruge den første værdi i 013X0001, det bliver 13

ja jeg kan godt udtrække numrene med 013X0001 - 013X4000
men får stadig for mange før og efter

Jeg tænkte på om det var en ide, at samle samtlige numre
i et ark for sig og her sortere dem, og så bruge din sub
kun i dette ark?

er de altid sådan 013X0001 , og altid 9 tegn, med  bogstavet X

det hjælper ikke at sortere, det skulle den selv gør

altid dette format ###$#### men kan være 663X1050 eller 013L3850 eller
003L0221 eller 088H3301 ... osv..

klokken er mange, måske vi kan fortsætte i morgen :-)

nu regner den om til værdier, prøv at tjekke

Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato)
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    Dim Fra As Long, Til As Long, Værdi As Long
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)
Fra = Val(Left(Fradato, 3)) & Asc(Mid(Fradato, 4, 1)) & Val(Right(Fradato, 4))
Til = Val(Left(tildato, 3)) & Asc(Mid(tildato, 4, 1)) & Val(Right(tildato, 4))
    For Each Ws In Worksheets

        If Ws.Name <> "Udtræk" Then    ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
            For I = 1 To UBound(Data)
            Værdi = Val(Left(Data(I, A3), 3)) & Asc(Mid(Data(I, A3), 4, 1)) & Val(Right(Data(I, A3), 4))
                If Værdi >= Fra And Værdi <= Til Then
                    For C = 0 To Col - 1
                        Uddata(X, C) = Data(I, C + 1)
                    Next
                    X = X + 1
                End If
            Next
        End If

    Next Ws

    For I = 1 To UBound(Uddata)
        For C = 0 To Col - 1
            If Uddata(I, C) = 0 Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

gir #VÆRDI! i alle felter

den virkede da jeg testede

{=FilterData(A2:H90;A2;C1;E1)}  013G5301  til 013G5301 gir :

003L0107 første nummer i første ark
013g0279 første nummer i andet ark
013G1230 første nummer i tredie ark
013G3088 første nummer i fjerde ark
013G5055 første nummer i femte ark
013G5301 Denne skal med og ikke andre *************
013G5400 første nummer i sjette ark
013G5601 første nummer i syvende ark
013G5994 første nummer i ottende ark
013G6122 første nummer i niende ark
013R9001 første nummer i tiende ark
013U0449 første nummer i elvte ark
082F1135 første nummer i tolvte ark
813X0019 første nummer i tretne ark
663X1048 første nummer i fjortne ark

{=FilterData(A1:H90;A2;C1;E1)}  013G5301  til 013G5301 gir :

VARE NR.
VARE NR.
VARE NR.
VARE NR.
013G5054
013G5301 Denne skal med
VARE NR.
VARE NR.
VARE NR.
VARE NR.
VARE NR.
VARE NR.
VARE NR.
VARE NR.
VARE NR.

Ok den gik i fejl, hvis der ikke var data i søgekolonnen, det er rettet nu.


Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato)
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    Dim Fra As Long, Til As Long, Værdi As Long
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)
    Fra = Val(Left(Fradato, 3)) & Asc(Mid(Fradato, 4, 1)) & Val(Right(Fradato, 4))
    Til = Val(Left(tildato, 3)) & Asc(Mid(tildato, 4, 1)) & Val(Right(tildato, 4))
    For Each Ws In Worksheets
        If Ws.Name <> "Udtræk" Then    ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
            For I = 1 To UBound(Data)
            If Data(I, A3) = "" Then Exit For
                Værdi = Val(Left(Data(I, A3), 3)) & Asc(Mid(Data(I, A3), 4, 1)) & Val(Right(Data(I, A3), 4))
                If Værdi >= Fra And Værdi <= Til Then
                    For C = 0 To (Col - 1)
                        Uddata(X, C) = Data(I, C + 1)
                        Debug.Print Uddata(X, C)
                    Next
                End If
                Debug.Print I
            Next
        End If
    Next Ws
    For I = 0 To UBound(Uddata)
        For C = 0 To Col - 1
            If Uddata(I, C) = 0 Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

hej kabbak
#VÆRDI! i alle celler
er det den sidste sub fra i går du har rettet ?
den næst sidste var tæt på! :-)

ja det var den sidste fra i går

jeg testede den på det du skrev 08/02-2006 16:31:13, og brugte også den formel, så jeg læste mere en der var data i

skal jeg formatere mine celler for at få den til at virke,eller?

nej den virkede med dine data

Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato)
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    Dim Fra As Long, Til As Long, Værdi As Long
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)
    Fra = Val(Left(Fradato, 3)) & Asc(Mid(Fradato, 4, 1)) & Val(Right(Fradato, 4))
    Til = Val(Left(tildato, 3)) & Asc(Mid(tildato, 4, 1)) & Val(Right(tildato, 4))
    For Each Ws In Worksheets
        If Ws.Name <> "Udtræk" Then    ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
            For I = 1 To UBound(Data)
            If Data(I, A3) = "" Then Exit For
                Værdi = Val(Left(Data(I, A3), 3)) & Asc(Mid(Data(I, A3), 4, 1)) & Val(Right(Data(I, A3), 4))
                If Værdi >= Fra And Værdi <= Til Then
                    For C = 0 To (Col - 1)
                        Uddata(X, C) = Data(I, C + 1)
                    Next
                End If
            Next
        End If
    Next Ws
    For I = 0 To UBound(Uddata)
        For C = 0 To Col - 1
            If Uddata(I, C) = 0 Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

fjernede lige debug.print

får stadig #VÆRDI! i alle celler
er det mig der gør noget forkert?

hver gang jeg afprøver en ny sub, markerer jeg A1:H1500 i ark 'Udtræk'
og trykker F2, CTRL + SHIFT + ENTER

prøv at sende filen,så ser jeg på den

kabbak snabela tiscali punktum dk

ok sendt

Jeg ved ikke om der er begrænsninger på hvormeget en funktion kan have i et array,
men jeg satte området ned til =FilterData(A2:H48;A2;C1;E1)
så kom værdierne, men hvis jeg satte den op med bare en række til =FilterData(A2:H49;A2;C1;E1), så skrev den #VÆRDI! i alle celler.

jeg har ændret så den søger på strengværdi i stedet for talværdi, prøv at teste.




Public Function FilterData(Dataområde As Range, Datokolonne, Fradato, tildato) As Variant
    Dim Uddata(), A1 As Long, A2 As Long, A3 As Long, I As Long, C As Long, X As Long
    Dim Fra As String, Til As String, Værdi As String
    X = 0
    A1 = Dataområde.Column
    A2 = Datokolonne.Column
    A3 = (A2 + 1) - A1
    Col = Dataområde.Columns(Dataområde.Columns.Count).Column
    RW = Dataområde.Rows(Dataområde.Rows.Count).Row
    ReDim Uddata(RW * (Worksheets.Count - 1), Col - 1)
    Fra = Val(Left(Fradato, 3)) & Asc(Mid(Fradato, 4, 1)) & Val(Right(Fradato, 4))
    Til = Val(Left(tildato, 3)) & Asc(Mid(tildato, 4, 1)) & Val(Right(tildato, 4))
    For Each Ws In Worksheets
        If Ws.Name <> "Udtræk" Then    ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range(Dataområde.Address)
            For I = 1 To UBound(Data)
            If Data(I, A3) = "" Then Exit For
                Værdi = Val(Left(Data(I, A3), 3)) & Asc(Mid(Data(I, A3), 4, 1)) & Val(Right(Data(I, A3), 4))
                If Værdi >= Fra And Værdi <= Til Then
                    For C = 0 To (Col - 1)
                        Uddata(X, C) = Data(I, C + 1)
                    Next
                End If
            Next
        End If
       
    Next Ws
    For I = 0 To UBound(Uddata)
        For C = 0 To Col - 1
            If IsEmpty(Uddata(I, C)) Then Uddata(I, C) = ""
        Next
    Next
    FilterData = Uddata
End Function

tester

ok her
jeg vil forsøge om den vil acceptere færre kolonner, så jeg
i stedet kan få flere rækker, ellers kan jeg jo kun udtrække
halvdelen af de ark, der er 90 rækker i
men du har nok ret vdr. for stort område!

tak for hjælpen kabbak
smid et svar
v.h. Poul

ups, nu får jeg kun et nummer uanset jeg udvider intervallet

skal lige et ærinde, er tilbage ca. 21.00

Jeg har drobbet den funktion, har er en makro, special til dit forbrug.

I arket "Udtræk"'s modul

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$1" Or Target.Address = "$E$1" Then
FindData
End If
End Sub


I et almindelig modul, samme sted som du har funktionen


Public Sub FindData()
Dim X As Long, I As Long, Fra As String, Til As String
X = 2
Application.ScreenUpdating = False
Fra = Sheets("Udtræk").Range("C1")
Til = Sheets("Udtræk").Range("E1")
Sheets("Udtræk").Range("A2:H1000").ClearContents
Sheets("Udtræk").Range("A2:H1000").ClearComments
For Each Ws In Worksheets
        If Ws.Name <> "Udtræk" Then    ' NAVNET PÅ RESULTAT ARKET
            Data = Worksheets(Ws.Name).Range("A2:H200")
            For I = 1 To UBound(Data)
            If Data(I, 1) = "" Then Exit For
                If Data(I, 1) >= Fra And Data(I, 1) <= Til Then
              Worksheets(Ws.Name).Range("A" & I + 1 & ":H" & I + 1).Copy Sheets("Udtræk").Range("A" & X)
                X = X + 1
                End If
            Next
        End If
    Next Ws
    Application.ScreenUpdating = True
End Sub

Inden du kører makroen, skal du lige fjerne det område som funktionen dækker i arket.

tester..

Skal jeg stadig markere i ark 'Udtræk' + =FilterData(..  ?

den tjekker når du skriver i C1 eller E1

Funktionen fra tidligere skal ikke bruges

den tjekker 1000 rækker på alle ark, så ingen markering.

det var forkert

den tjekker 200 rækker på alle ark, så ingen markering.
du skal rette 200 i denne linie, hvis du får flere rækker

Data = Worksheets(Ws.Name).Range("A2:H200")

jo jo kabbak det nu ser det rigtig ud :-)

Jeg smider et svar, hvis du er tilfreds ;-))

Det var en hård nød, men godt du fandt en løsning :-)
Smid et svar, 100 point er bestemt givet godt ud

jeg vil forsøge om jeg kan udvide funktionen til
at kikke i kolonne B efter adresse så jeg evt. kan
få en liste på numre uden adresser.

kikser det, vender jeg måske tilbage med et spørgsmål
om nogen dage
tak for hjælpen kabbak.. well done

selv tak