Filtrere data og dele ud af ID i kolonne A

Skulle nok være muligt..

Er der et sæt regler for ID --> ArkNr

Hej,

Ja:
15 = ark4
12 = ark3
14 = ark7
5  = ark8

ID'et er som sagt placeret i kolonne A.

Ok & tak ... et øjeblik

OBS: Første ark kaldes "Rådata" - herunder anbringes VBA-koden (højreklik på ark / Vis programkode)
Aktiveres fra Excel: Alt+F8 - afspil makro "fordelingAfRådata"



Dim sidsteRække As Long, sidsteKolonne As Long, ræk As Long
Dim idNr As Byte, arkNr As Byte, IdListe As Variant, ArkListe As Variant
Public Sub fordelingAfRådata()
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
    sidsteKolonne = ActiveCell.SpecialCells(xlLastCell).Column
 
    IdListe = Array(15, 12, 14, 5)                  'Id-nr
    ArkListe = Array(4, 3, 7, 8)                    'Arknr, hvor ID-nr placeres - do index.
 
    For ræk = 2 To sidsteRække
        idNr = Cells(ræk, 1)
        arkNr = findArkNr(idNr)
       
        If arkNr > 0 Then
            ActiveSheet.Rows(ræk).Select
            Selection.Copy
            indsætPåArk arkNr
            Application.CutCopyMode = False
            ActiveWorkbook.Sheets("Rådata").Activate
           
        Else
            MsgBox ("Id " & CStr(idNr) & " kunne ikke findes i liste")
        End If
    Next ræk
End Sub
Private Function findArkNr(idNr)
Dim ix As Byte
    For ix = 0 To UBound(IdListe)
        If idNr = IdListe(ix) Then
            findArkNr = ArkListe(ix)
            Exit Function
        End If
    Next ix
   
    findArkNr = 0
End Function
Private Sub indsætPåArk(arkNr)
Dim ræk
    ActiveWorkbook.Sheets("Ark" & CStr(arkNr)).Select
        For ræk = 2 To 65000
            If ActiveSheet.Cells(ræk, 1) = "" Then
                ActiveSheet.Rows(CStr(ræk)).Select
                ActiveSheet.Paste
                Exit Sub
            End If
        Next ræk
End Sub

Det er over al forventning! Tak...
Hvis nu jeg gerne vil omdøbe arkene til forskellige navne.

4 = Erhverv
3 = Test
7 = Udland
8 = Potentielle

Hvordan gøres det så?

Intet problem - vender tilbage lidt senere....

Rem Version 2

Dim sidsteRække As Long, ræk As Long
Dim idNr As Byte, arkNavn As String, IdListe As Variant, ArkListe As Variant
Public Sub fordelingAfRådata()
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
 
    IdListe = Array(15, 12, 14, 5)                                  'Id-nr
    ArkListe = Array("Erhverv", "Test", "Udland", "Potientielle")  'Arknavn, hvor ID-nr placeres - do index.
 
    For ræk = 2 To sidsteRække
        idNr = Cells(ræk, 1)
        arkNavn = findArkNavn(idNr)
       
        If arkNavn <> "" Then
            ActiveSheet.Rows(ræk).Select
            Selection.Copy
            indsætPåArk arkNavn
            Application.CutCopyMode = False
            ActiveWorkbook.Sheets("Rådata").Activate
           
        Else
            MsgBox ("Id " & CStr(idNr) & " kunne ikke findes i liste")
        End If
    Next ræk
End Sub
Private Function findArkNavn(idNr)
Dim ix As Byte
    For ix = 0 To UBound(IdListe)
        If idNr = IdListe(ix) Then
            findArkNavn = ArkListe(ix)
            Exit Function
        End If
    Next ix
   
    findArkNavn = ""
End Function
Private Sub indsætPåArk(arkNavn)
Dim ræk
    ActiveWorkbook.Sheets(arkNavn).Select
        For ræk = 2 To 65000
            If ActiveSheet.Cells(ræk, 1) = "" Then
                ActiveSheet.Rows(CStr(ræk)).Select
                ActiveSheet.Paste
                Exit Sub
            End If
        Next ræk
End Sub

Det var også den rettelse jeg selv havde lavet, men tak igen.
Et sidste spørgsmål...? (hvis du vil have yderligere point så opretter jeg bare et spm. mere.)

Kan man få den til at fjerne rækkerne i rådata så man på den måde kan kontrollere at alle linjerne er blevet kopieret?

//Mads...

Ja - det skulle ikke være et større problem...

Rem Version 3

Dim sidsteRække As Long, ræk As Long
Dim idNr As Byte, arkNavn As String, IdListe As Variant, ArkListe As Variant
Public Sub fordelingAfRådata()
    sidsteRække = ActiveCell.SpecialCells(xlLastCell).Row
 
    IdListe = Array(15, 12, 14, 5)                                  'Id-nr
    ArkListe = Array("Erhverv", "Test", "Udland", "Potientielle")  'Arknavn, hvor ID-nr placeres - do index.
 
    For ræk = 2 To sidsteRække
        idNr = Cells(ræk, 1)
        If idNr > 0 Then
            arkNavn = findArkNavn(idNr)
       
            If arkNavn <> "" Then
                ActiveSheet.Rows(ræk).Select
                Selection.Copy
                indsætPåArk arkNavn
                ActiveWorkbook.Sheets("Rådata").Activate
           
                Selection.Delete
                ræk = ræk - 1
                Application.CutCopyMode = False
            Else
                MsgBox ("Id " & CStr(idNr) & " kunne ikke findes i liste")
            End If
        End If
    Next ræk
End Sub
Private Function findArkNavn(idNr)
Dim ix As Byte
    For ix = 0 To UBound(IdListe)
        If idNr = IdListe(ix) Then
            findArkNavn = ArkListe(ix)
            Exit Function
        End If
    Next ix
   
    findArkNavn = ""
End Function
Private Sub indsætPåArk(arkNavn)
Dim ræk
    ActiveWorkbook.Sheets(arkNavn).Select
        For ræk = 2 To 65000
            If ActiveSheet.Cells(ræk, 1) = "" Then
                ActiveSheet.Rows(CStr(ræk)).Select
                ActiveSheet.Paste
                Exit Sub
            End If
        Next ræk
End Sub

Mange tak! Beklager den sene tilbagemelding.

Selv og Ok...