VBA Makro to Copy Certain Ranges isn't Properly Executing-CodePudding

First time poster here!

Im currently Working on a VBA problem that i just cant seem to crack. I have a Macro written that is supposed to identify cells containing data in a column, and then copy multiple columns from said cells row into another worksheet.

This is IN THEORY working as intended, but i got suspicious recently that it feels like im coming up a bit short on the amount of Rows copied and ended up double checking.

19 rows that fit the Criteria to be copied by my Macro (And dont contain any words that come up in my 5 exceptions) just arent being copied and i cant for the life of me figure out what the problem is. I have tried to go through the Macro step by step, working with stoping points and changing around the Makro itself but nothing I tried is fixing the issue.

My theory so far is that maybe theres something wrong with the Cells in the sheet its supposed to copy from that just prevents the data from being copied by the macro or something like that, but i am pretty new to VBA so i wanted to ask you all if im just missing something

Heres my code:


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

Any and all help would be greatly appreciated! :D

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.

Progress on this is very slow as i really am not good at VBA, but im doing my best to use Autofilter commands.

CodePudding user response：

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

CodePudding user response：

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