VBA-kode på at splitte en tabel til flere.

1. Er der kun 3 kolonner i arket ?
2. Må de separerede tabellerne gerne ligge i hver deres faneblad ?
3. Ligger værdierne altid i samme kolonne ?

Tak for hurtig respons!

Nej der er flere kolonner men de er mere eksemplet i det! Det ville være en fordel med kun et faneblad (er stort i forvejen) men ingen betingelse.
Og ja værdierne ligger altid i samme kolonne og skal altid flyttes til samme kolonne.

Har du overvejet at benytte en Pivottabel ?

Eller funktionen Sorter? Sortering kan tage visse dele af en matrix og lægge ud et andet sted, baseret på kriterier...

Der findes mange muligheder, og med mindre dette er en gentagende hændelse, så kan det måske være overkill at begynder at programmere sig ud af problemerne.
Men ellers kunne dit program se ud som følger :

Sub SplitUpTable()

dim STAT as range
dim REAL as range
dim FLEX as range
dim DATA as range

set STAT =SHEET("STAT").Cells(1,1)
set REAL =SHEET("REAL").Cells(1,1)
set FLEX =SHEET("FLEX").Cells(1,1)

cells(1,1).select
set DATA = range(selection,selection.end(xlDown))

for each cell in DATA
    if cell.offset(0,3)="Stat" then
        for x=0 to data.columns.count-1
        STAT.end(xldown).offset(1,x)= cell.offset(0,x)
        next
    end if

    if cell.offset(0,3)="REAL" then
        for x=0 to data.columns.count-1
        REAL.end(xldown).offset(1,x)= cell.offset(0,x)
        next
    end if
    if cell.offset(0,3)="FLEX" then
        for x=0 to data.columns.count-1
        FLEX.end(xldown).offset(1,x)= cell.offset(0,x)
        next
    end if
next cell

End sub

Jeg skal starte med at sige, at dette ikke er testet, det var bare en ide til, hvordan dette kunne gøres.

Umiddelbart ville jeg bruge funktion Sorter - Kopier til nyt område, men det er selvfølgelig bare mig.

Held og lykke med det.

Sorter vil langt fra være tilstrækkeligt, da det er en del af et stort regneark og der anvendes meget hyppigt!

Men jeg tester din koder og vender tilbage!

Prøv evt. også lige at hente http://tommy.bak.homepage.dk/filterogkopier.xls

Koden til dette ark kan også splitte en tabel ud i flere (hvert sit ark)

hoineg>> Hvis du sætter din makro-båndoptager igang og laver sorteringen som du gerne hvil have den, så får du en stump kode, som næsten ingen tilretning kræver, for at du kan bruge den i din makro. Vil gætte på at det er den hurtigste løsning i run-time.

Tak for input omkring sortering men det er ikke problemet - eksemplet er dog kraftigt simplificeret og kun en del af et større regneark. Sortering er derfor først aktuelt når uddeling er sket. Men "Xelor" har givet mig lidt input jeg arbejder med - selv om der skal udbygges en del. Tak foreløbig for alle input.

Denne splitter forudsætter følgende:
Du har oprettet 3 ark, som er navngivet "STAT", "REAL og "FLEX".
Den kolonne som skal evalueres for Stat,Real og Flex er den sidste kolonne i den tabel du evaluerer på.

Sub SplitUpTable()
    Dim rCell As Range
    Dim rCurReg As Range
    Dim sWks As String
    Dim lRow As Long
    Dim X As Long
   
    Set rCurReg = ActiveSheet.Range("A1").CurrentRegion
   
    For Each rCell In rCurReg.Columns(1).Cells
        With rCell
            sWks = UCase$(Left(.Offset(0, rCurReg.Columns.Count).Value, 4))
            lRow = Sheets(sWks).Range("A65536").End(xlUp).Row + 1
            For X = 1 To rCurReg.Columns.Count
                Sheets(sWks).Cells(lRow, X).Value = .Offset(0, X).Value
            Next X
        End With
    Next rCell
   
    Set rCell = Nothing
    Set rCurReg = Nothing
End Sub

hoineg> hjalp det dig ?

Hej Flemming! tak for input men jeg lå desværre med PC-virus er først lige kommet op at køre - er forhåbentligt klogere i aften eller morgen!

Desværre Flemming, jeg modtager en out of range fejlkode! Og jeg kan ikke spore hvor den går galt!

Du er velkommen til at sende mig arket fd@win-consult.com

Til Xelor! Din kode var desværre heller ikke særlig nyttefuld! Men jeg knokler videre - da der må være en løsning!

ovenstående har virket fint hos mig...

Så må jeg lave noget galt! Navngiver du også aktivt sheet?

Nej - har du celler, hvor der står andet end Stat,Flex eller Real ?
Findes disse ark ? hvilken linie stopper makro'en i når du trykker Debug ?
Sker der overhovedet noget ? Har du data i celle A1 ? Send mig arket.

Intet sker - jeg får ikke mulighed for en debug.
Der er tre kolonner i eksemplet (se spgm.) sidste kolonne indeholder fordelingsnøgle.
De tre ark er oprettet. og der er header i A1,B1 og C1.Data er i efterfølgende rækker -  med fordelingsnøgle i kolonne C.
Jeg kan desværre ikke sende dig andet end eksempelarket, da oprindeligt ark desværre indeholder interne oplysninger, som ikke må videreformidles.

fair nok - eksempelarket er fint nok.

Er på vej- og tak!

*ss* det er oz den forkerte version af makro'en du har fået LOL - prøv denne her :-)

Sub SplitUpTable()
    Dim rCell As Range
    Dim rCurReg As Range
    Dim sWks As String
    Dim lRow As Long
    Dim X As Long
   
    Set rCurReg = ActiveSheet.Range("A1").CurrentRegion
    Set rCurReg = rCurReg.Offset(1, 0).Resize(rCurReg.Rows.Count - 1, rCurReg.Columns.Count)
   
    For Each rCell In rCurReg.Columns(1).Cells
        With rCell
            sWks = UCase$(Left(.Offset(0, rCurReg.Columns.Count - 1).Value, 4))
            lRow = Sheets(sWks).Range("A65536").End(xlUp).Row + 1
            For X = 0 To rCurReg.Columns.Count - 1
                Sheets(sWks).Cells(lRow, X + 1).Value = .Offset(0, X).Value
            Next X
        End With
    Next rCell
   
    Set rCell = Nothing
    Set rCurReg = Nothing
End Sub

For X = 0 To rCurReg.Columns.Count - 1
    Sheets(sWks).Cells(lRow, X + 1).Value = .Offset(0, X).Value

kan oz se således ud:           
For X = 1 To rCurReg.Columns.Count
    Sheets(sWks).Cells(lRow, X).Value = .Offset(0, X - 1).Value

Fantastisk! Tusinde tak for hjælpen! 150p til dig

:-) ingen årsag :-)