Betinget kopiering fra et ark til et andet ark i Excel vha. VBA

Private Sub OverFoer()
    Set wsArk(1) = ActiveSheet
    For iCountA = 2 To Sheets.Count
        Set wsArk(iCountA) = Sheets(iCountA)
    Next iCountA
    Set rKolA = wsArk(1).Range("A1000")
    Set rKolA = Range(wsArk(1).Range("A1"), rKolA.End(xlUp))

    For iCount = 2 To 5
        iRow = 1
        For Each rCell In rKolA
            If rCell <> "" And rCell.Offset(0, 5).Value = iCount Then
              For iCells = 1 To 5
                    wsArk(iCount).Cells(iRow, iCells) = Cells(rCell.Row, iCells)
              Next iCells
              iRow = iRow + 1
            End If
        Next rCell
    Next iCount
End Sub
Private Sub Worksheet_Activate()
    OverFoer
End Sub

mvh Jan

Hej Jan

Tusind tak for hjælpen.

Plejer normalt bare at kunne køre mine makroer, men denne kan jeg ikke køre ligesom alle de andre. Har du også en løsning på det?

liges i ark 1 elles fjern private i private sub overfoer og lig den som du plejer

Jan

den jeg havde lavet kører når ark aktiveres

husk at slette

Private Sub Worksheet_Activate()
    OverFoer
End Sub

hvis du ligger det i et modul

Jan

En ny version med smårettelser og kommentarer

Option Explicit
Dim wsArk(5) As Worksheet
Dim rKolA As Range, rRow(5) As Range, rCell As Range
Dim iCountA As Integer
Dim iCount, iRow As Integer, iCells As Integer

Private Sub OverFoer() ' slet private hvis det skal bruges som macro
    Set wsArk(1) = ActiveSheet ' Data ark Skriv evt Sheet(1) hvis det bruges som macro
    For iCountA = 2 To Sheets.Count ' gennemløber arkene der skal overføres data til
        Set wsArk(iCountA) = Sheets(iCountA)
    Next iCountA
    Set rKolA = wsArk(1).Range("A1000")
    Set rKolA = Range(wsArk(1).Range("A1"), rKolA.End(xlUp))

    For iCount = 2 To Sheets.Count
        iRow = 1 ' første række som data skal over i så 1 ændres hvis kolonnerne har overskrifter
        For Each rCell In rKolA
            If rCell <> "" And rCell.Offset(0, 5).Value = iCount Then ' icount = Ark nr 2-? forventes at stå i "F"
              For iCells = 1 To 5
                    wsArk(iCount).Cells(iRow, iCells) = Cells(rCell.Row, iCells)
              Next iCells
              iRow = iRow + 1
            End If
        Next rCell
    Next iCount
End Sub
Private Sub Worksheet_Activate() ' Næste ter linier slettes hvis koden ikke sættes i ark-koden
    OverFoer
End Sub

Mvh Jan

Har indsat det sådan her nu:

Sub kopiering()

    Set wsArk(1) = ActiveSheet

    For iCountA = 2 To Sheets.Count
        Set wsArk(iCountA) = Sheets(iCountA)
    Next iCountA
    Set rKolA = wsArk(1).Range("A1000")
    Set rKolA = Range(wsArk(1).Range("A1"), rKolA.End(xlUp))

    For iCount = 2 To 5
        iRow = 1
        For Each rCell In rKolA
            If rCell <> "" And rCell.Offset(0, 5).Value = iCount Then
              For iCells = 1 To 5
                    wsArk(iCount).Cells(iRow, iCells) = Cells(rCell.Row, iCells)
              Next iCells
              iRow = iRow + 1
            End If
        Next rCell
    Next iCount
End Sub

Men den siger der kommer en sub eller funktionsfejl? Er det fordi jeg gør noget helt forkert? Er kun vant til at sidde med helt simple makroer.

Her er en Makro ver.

Option Explicit
Dim wsArk(5) As Worksheet
Dim rKolA As Range, rRow(5) As Range, rCell As Range
Dim iCountA As Integer
Dim iCount, iRow As Integer, iCells As Integer

Sub OverFoer()
    Set wsArk(1) = Sheet(1)
    For iCountA = 2 To Sheets.Count ' gennemløber arkene der skal overføres data til
        Set wsArk(iCountA) = Sheets(iCountA)
    Next iCountA
    Set rKolA = wsArk(1).Range("A1000")
    Set rKolA = Range(wsArk(1).Range("A1"), rKolA.End(xlUp))

    For iCount = 2 To Sheets.Count
        iRow = 1 ' første række som data skal over i så 1 ændres hvis kolonnerne har overskrifter
        For Each rCell In rKolA
            If rCell <> "" And rCell.Offset(0, 5).Value = iCount Then ' icount = Ark nr 2-? forventes at stå i "F"
              For iCells = 1 To 5
                    wsArk(iCount).Cells(iRow, iCells) = Cells(rCell.Row, iCells)
              Next iCells
              iRow = iRow + 1
            End If
        Next rCell
    Next iCount
End Sub

mvh Jan

Hej Jan,

kan jeg ikke prøve at sende en Excel fil til dig, så kan du se, hvad makroen skal kunne gøre helt præcist? For kan ikke få den ovenstående til at fungere helt perfekt.

sendt pb.