Macro problem, vanskelig

[chris_83]

hei sitter a jobber med en macro pa jobben. Den skal funke pa en 25.000 rows rapport.

 

Alt i "" er en egen column i excel

1. Finn summen av "Costnadene" til "Selskap" sortert etter "Gruppe"

 

Regnearket inneholder ca 500 "Grupper" og flere "Selskaper" som finnes under flere "Grupper". Og igjen Selskaper kan ha flere "kostnader

 

2. Hvis total summen = 0, da skal alle de linjene som horer til slettes.

 

Eksempel fra regnearket:

 

101 INFORMATION RESOURCES INC 5388.51

101 INFORMATION RESOURCES INC 5388.51

101 INFORMATION RESOURCES INC -5388.51

101 INSIDE RESEARCH. 302

101 INSIDE RESEARCH. -302

101 INTERCALL CONFERENCING SERVICE 20

101 INTERCALL CONFERENCING SERVICE 20

101 INTERCALL CONFERENCING SERVICE -20

101 INTERCALL CONFERENCING SERVICE -20

101 INTERCALL CONFERENCING SERVICE -81.04

101 INTERCALL CONFERENCING SERVICE -20

101 INTERCALL CONFERENCING SERVICE -81.04

101 OFFICE DEPOT UK LTD -63.69

101 STANCO CHAUFFEUR DRIVE -29

 

Eksempel pa noe som skal slettes, tatt fra det over:

 

101 INSIDE RESEARCH. 302

101 INSIDE RESEARCH. -302

 

Sum = 0 slik (302 - 302)

 

 

Haper jeg har gjort det forstaaelig.

 

Hvis noen har noen ide pa hvordan jeg kan gjore dette, sa takker jeg pa mine knear. Har jobbet med denne i 2 dager na.

 

Hvis det er onskelig kan jeg legge ut det jeg har gjort sa langt, (men den funker ikke)

 

Takk

Endret 4. oktober 2005 av cgsimons

[aadnk]

Jeg er litt usikker på om jeg har forstått deg riktig, men kan følgende kode fungerer:

 

Public Sub RemoveDuplicates(oRange As Range)

 

    Dim Cell As Range, UnderElement As Range, aLine As Variant, aCompare As Variant

    Dim Equals As Collection, Sum As Double

   

    ' Gå gjennom alle tilgjengelige celler i det angitte området

    For Each Cell In oRange

   

        ' Ekskluder linje dersom den er tom

        If LenB(Cell.Value) <> 0 Then

   

            ' Forny liste over elementer

            Set Equals = New Collection

   

            ' Legg til dette elementet

            Equals.Add Cell

   

            ' Last inn den gjeldende linjes data

            aLine = ExtractData(Cell.Value)

       

            ' Initialiser summer-variabel

            Sum = aLine(3)

       

            ' Finn elementer av samme selskap og gruppe

            For Each UnderElement In oRange

           

                ' Ikke søk dersom elementet er tomt

                If LenB(UnderElement.Value) <> 0 And Not (UnderElement.Row = Cell.Row And UnderElement.Column = Cell.Column) Then

           

                    ' Last inn denne lijens data

                    aCompare = ExtractData(UnderElement.Value)

               

                    ' Se om selskapet og gruppen korresponderer

                    If LCase(aLine(2)) = LCase(aCompare(2)) Then

                   

                        ' Legg til cellen i listen

                        Equals.Add UnderElement

                   

                        ' Summer dens verdi

                        Sum = Sum + aCompare(3)

                   

                    End If

               

                End If

           

            Next

           

            ' Dersom summen av alle elementer er null, ...

            If Sum = 0 Then

           

                ' ... må cellene "slettes"

                For Each UnderElement In Equals

               

                    ' Slett cellen

                    UnderElement.Delete

                   

                Next

           

            End If

       

        End If

   

    Next

 

End Sub

 

Public Function ExtractData(sLine As String) As Variant

 

    Dim aTemp As Variant, aOut As Variant, lngPos As Long

 

    ' Alloker utdata

    ReDim aOut(1 To 3)

 

    ' Først, del opp linje i to ymse segmenter

    aTemp = Split(sLine, " ", 2)

 

    ' Kalkuler hvorhen i det andre elementet vi må kutte

    lngPos = InStrRev(aTemp(1), " ")

 

    ' Deretter lager vi utdata-arrayen vi returnerer

    aOut(1) = aTemp(0)

    aOut(2) = Mid(aTemp(1), 1, lngPos - 1)

    aOut(3) = Val(Mid(aTemp(1), lngPos + 1))

 

    ' Returner array

    ExtractData = aOut

 

End Function

 

Du kaller i hvert fall koden således:

 

RemoveDuplicates Range("A1", "A14")

[Harald Staff]

Skal du slette selve rådataene eller bare skjule null-kontoene fra et sammendrag ? En Pivot-tabell (Data-menyen i Excel) gir deg kloke analyser og sammendrag som dette på få sekunder og uten kode, som skapt for et dataoppsett som ditt.

 

HTH. beste hilsen Harald