konsolidering af lister ud fra 2 betingelser

E F G er naturligvis kolonne overskrifter..

prøv denne makro

Sub TælSammen()
Dim B As Long, Data As Variant, Res As Variant, I As Long
On Error GoTo Slut
B = Range("B65536").End(xlUp).Row ' finder sidste række med data
Data = Range("A1:B" & B) ' nummer kolonne A og tal kolonne B
Res = Range("E1:G" & B) ' Skriver resultatet i Kolonne E, F  og G
I = 1
For T = 1 To UBound(Data)
  If Data(T, 2) = Data(T + 1, 2) And Data(T + 1, 1) = Data(T, 1) + 1 Then
      If Res(I, 1) = "" Then
        Res(I, 1) = Data(T, 1)
      End If
    Res(I, 2) = Data(T, 1)
    Res(I, 3) = Data(T, 2)
    GoTo Videre
    End If
  If Data(T, 2) = Data(T + 1, 2) And Data(T + 1, 1) <> Data(T, 1) + 1 Then
    If Res(I, 1) = "" Then
      Res(I, 1) = Data(T, 1)
    End If
      Res(I, 2) = Data(T, 1)
      Res(I, 3) = Data(T, 2)
      I = I + 1
      GoTo Videre
    End If
  If Data(T, 2) <> Data(T + 1, 2) And Data(T + 1, 1) = Data(T, 1) + 1 Then
    If Res(I, 1) = "" Then
      Res(I, 1) = Data(T, 1)
    End If
    Res(I, 2) = Data(T, 1)
    Res(I, 3) = Data(T, 2)
    I = I + 1
    Else
    If Res(I, 1) = "" Then
      Res(I, 1) = Data(T, 1)
    End If
    Res(I, 2) = Data(T, 1)
    Res(I, 3) = Data(T, 2)
    I = I + 1
    End If
   
Videre:
Next

Slut:
  Res(I, 2) = Data(T, 1)
  Res(I, 3) = Data(T, 2)
Range("E1:G" & B) = Res ' Skriver resultatet i Kolonne E, F  og G
End Sub

sæt lige denne ind under on error

Range("E1:G" & B).Clear

Hej Kabbak,

Den er der ikke helt endnu for den nye liste indeholder jo alle nummre fra den oprindelige liste. dvs den er lige så lang som den første.

dette resultat:

651644    651644    54
651645    651645    54
651646    651646    54
651647    651647    54
651648    651648    54
651649    651649    54
651650    651650    54


skulle se således ud:


651644 651650  54

for der er kun 1 mellem hvert nummer og Antal er 54

Kolonne A skal være sorteret stigende, for at den virker

Sub TælSammen()
Dim B As Long, Data As Variant, Res As Variant, I As Long
On Error GoTo Slut
B = Range("B65536").End(xlUp).Row ' finder sidste række med data
Data = Range("A1:B" & B) ' nummer kolonne A og tal kolonne B
Range("E1:G" & B).Clear
Res = Range("E1:G" & B) ' Skriver resultatet i Kolonne E, F  og G
I = 1
For T = 1 To UBound(Data)
  If Data(T, 2) = Data(T + 1, 2) And Data(T + 1, 1) = Data(T, 1) + 1 Then
      If Res(I, 1) = "" Then
        Res(I, 1) = Data(T, 1)
      End If
    Res(I, 2) = Data(T, 1)
    Res(I, 3) = Data(T, 2)
    GoTo Videre
    End If
  If Data(T, 2) = Data(T + 1, 2) And Data(T + 1, 1) <> Data(T, 1) + 1 Then
    If Res(I, 1) = "" Then
      Res(I, 1) = Data(T, 1)
    End If
      Res(I, 2) = Data(T, 1)
      Res(I, 3) = Data(T, 2)
      I = I + 1
      GoTo Videre
    End If
  If Data(T, 2) <> Data(T + 1, 2) And Data(T + 1, 1) = Data(T, 1) + 1 Then
    If Res(I, 1) = "" Then
      Res(I, 1) = Data(T, 1)
    End If
    Res(I, 2) = Data(T, 1)
    Res(I, 3) = Data(T, 2)
    I = I + 1
    Else
    If Res(I, 1) = "" Then
      Res(I, 1) = Data(T, 1)
    End If
    Res(I, 2) = Data(T, 1)
    Res(I, 3) = Data(T, 2)
    I = I + 1
    End If
   
Videre:
Next

Slut:
  Res(I, 2) = Data(T, 1)
  Res(I, 3) = Data(T, 2)
Range("E1:G" & B) = Res ' Skriver resultatet i Kolonne E, F  og G
End Sub

Det er f... utroligt hvad du kan med et regneark.

Tester det lige igennem - smid lige et svar, så er du klar til at få point.

virker det nu. ?

og et svar

lige her på falderebet, har du et bud på hvordan man får excel til at acceptere tal på 16-20 cifre? Når jeg sæter tal ind bliver 00057056242006516571
til 5,70562E+16.

(og det skal behandles som tal.)

15 cifre i regnearket max... hvis der skal regnes på dem. Noget flere i vba.

tak for hjælpen alligevel.

hvad skal du bruge så store tal til ??
(mange begrænsninger kan jo omgåes)

tak for point ;-))

jeg skal kun bruge de siste 6 cifre - men jeg er jo nød til at importerer hele tallet før jeg kan 'nappe' de sidste 6 cifre.

Og jeg har desværre lige fundet ud af at det ikke går at sorterer data stigende - der må ikke laves om på rækkefølgen...

Har du et bud - ellers laver jeg et nyt sp. - æv

Kan du sende et testark med data på, så skal jeg se.


Sendtil#kabbak@tiscali.dk

fjern Sendtil#

Hej,
Tak for tilbudet - men af een eller anden grund ser det ud til at virke?? (måske har det noget med min formatering at gøre)

Jeg skal lige prøve at bruge det i praksis de næste par dage - så kan det godt være at jeg vil tage i mod tilbudet, hvis det stadig er åbent.