Copy Ranges not containing exceptions

Question

I have a macro that is supposed to identify cells containing data in a column, and then copy multiple columns from said cells row into another worksheet.

19 rows that fit the Criteria to be copied (and don't contain any words that come up in my 5 exceptions) aren't being copied.

I tried to go through the macro step by step, working with stopping points and changing around the macro itself.

My theory is there is something wrong with the Cells in the sheet it is supposed to copy from.

Sub Copy_Range()

Dim zelle, cell As Range

Dim i As Long

On Error Resume Next

Worksheets("Worksheet 4").Activate

Application.GoTo Worksheets("Worksheet 4").Range("C2:H1000")

Application.ScreenUpdating = False

 

Worksheets("Worksheet 4").Activate

Range("C2:C1000,D2:D1000,E2:E1000,F2:F1000,G2:G1000,H2:H1000").Clear

 

Worksheets("Worksheet 1").Activate

Range("A6").Activate

 

'This part Shows an alert when theres no Data entered in column A

 

If WorksheetFunction.CountA(Range("A6:A1000")) = 0 Then

    Dim click As Integer

    click = MsgBox(prompt:="There was no data Entered in Column A", Buttons:=vbExclamation)

    Cells(1, 1).Select

    Exit Sub

End If

 

Set Tbl2 = ThisWorkbook.Worksheets("Worksheet 1").ListObjects("Tabelle33")

LastRow4 = Tbl2.ListColumns(1).Range.Rows.Count

Set cell = Cells(ActiveCell.Row, ActiveCell.column)

 

'This part is supposed to look through Column A in Worksheet 1

'If there is data entered in column A of a row the Macro copies the data entered in column 1, 2, 3, 5, 6 and 7 of that row into Worksheet 4,

'UNLESS the Data entered in Column A is one of 5 exceptions.

 

For Each zelle In Worksheets("Worksheet 1").Range(Cells(Rows.Count, cell.column), Cells(cell.Row, cell.column))

    If ActiveCell.Value = "" Then

        Selection.End(xlDown).Select

    **ElseIf ActiveCell.Value = "Exception 1" Then**

            **Selection.End(xlDown).Select**

    **ElseIf ActiveCell.Value = "Exception 2" Then**

           **Selection.End(xlDown).Select**

    **ElseIf ActiveCell.Value = "Exception 3" Then**

            **Selection.End(xlDown).Select**

    **ElseIf ActiveCell.Value = "Exception 4" Then**

            **Selection.End(xlDown).Select**

    **ElseIf ActiveCell.Value = "Exception 5" Then**

            **Selection.End(xlDown).Select**

   

    Else

        Union(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 2), Cells(ActiveCell.Row, 3), Cells(ActiveCell.Row, 5), Cells(ActiveCell.Row, 6), Cells(ActiveCell.Row, 7)).Copy

        Application.GoTo Worksheets("Worksheet 4").Cells(2, 3)

        Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats

        Selection.PasteSpecial Paste:=xlPasteAll

        Range("C2:H2").Select

        Selection.Insert Shift:=xlDown

        Worksheets("Worksheet 1").Activate

        ActiveCell.Offset(1, 0).Select

    End If

 

Next

 

    Worksheets("Worksheet 4").Activate

    Range("C2:H1000").Interior.Color = xlNone

 

End Sub

Edit: the problem seems to be the ** Starred ** lines in my code aka. my "Exceptions"

I have since removed that snippet and am working on a new bit of code that filters through column A and then deletes the Exceptions after the fact, instead of not copying them from the start.

Answer 1

You are missing Dim zelle AS RANGE While defining variables on the same line each varaible must be defined separately so Dim zelle as range, cell as range

Also try replacing If ActiveCell.Value by If zelle.value

Answer 2

Try this code:

Dim LR as long Dim cell as range

LR = Thisworkbook.worksheets("name of your worksheet").range("A" & rows.count).end(xlup).row

for cell in range("A1","A"& LR)

if cell.value =

 'add here all your exceptions scenarios

else

  'copy the data code

end if

next cell