error generated in complete code but when run on its own.

Afro_Cookie · Jan 7, 2022

I'm in the final stages of this and I could use some help.

There is a bug that is causing merged cells to unmerge and shifting my data on my 'Filtered' sheet, which I don't understand as the piece of code isn't interacting with that sheet. I tried running the piece of code on its own and there were no errors.

error generated at this point when entire code is run

VBA Code:

'copying the 'QC info' data from 'yesterday' to 'today'
Sheets("Yesterday").Range("Table1[QC Notes]").Copy Sheets("Today").Range("I2")

M file consists of three sheets, that may need to be duplicated, that I'll post below the completed code.

VBA Code:

Sub ColourMeElmo()

Application.ScreenUpdating = False

'establish the criteria for colouring cells
Dim i As Long, r1 As Range, r2 As Range

'code for selecting which cells get coloured backgrounds
Sheets("Filter").Select
On Error Resume Next
For i = 6 To 150
Set r1 = Range("B" & i)
Set r2 = Range("L" & i & ":S" & i)
If r1.Value = "" Then r2.Interior.Color = vbYellow
 Next i

' For "Today" data that gets copied, pasted into the 'Today' sheet from 'Filter', after formatting has taken place
ActiveSheet.Range("L6", ActiveSheet.Range("L6").End(xlDown).End(xlToRight)).Copy
Sheets("Today").Range("K2").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Today").Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
          
' For "Yesterday" data that gets copied, pasted into the 'yesterday' sheet from 'fileter', after formatting has taken place
Sheets("Filter").Range("B6", ActiveSheet.Range("B6").End(xlDown).End(xlToRight)).Copy
Sheets("Yesterday").Range("A2").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Yesterday").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'overrighting current table data with the newly filtered data
Sheets("Today").Range("K2").CurrentRegion.Offset(1, 0).Cut Range("A2")

'copying the 'QC info' data from 'yesterday' to 'today'
Sheets("Yesterday").Range("Table1[QC Notes]").Copy Sheets("Today").Range("I2")
        
'Deleting blank rows in table
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=1, Criteria1:="="
ActiveSheet.AutoFilter.Range.Offset(1).Delete
ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=1

'delete all rows from 'Yesterday' table
Sheets("Yesterday").Select
If Not ActiveCell.ListObject Is Nothing Then
ActiveCell.ListObject.DataBodyRange.Delete
End If
        
'transfer data from 'Today' to 'Yesterday'
Sheets("Today").Range("A1").CurrentRegion.Offset(1, 0).Cut Sheets("Yesterday").Range("A2")

'reset sheets
Sheets("Today").Columns("J:S").EntireColumn.Delete
Sheets("Filter").Range("A:T").Interior.Color = xlNone
    
'go to main sheet
Sheets("Yesterday").Range("A2").Select
    
Application.ScreenUpdating = True

End Sub

Sheet 1 "Yesterday"
Sheet 2 "Today"
Sheet 3 "Filter"

Sheet 1

logistics shipping playground.xlsm

A

B

C

D

E

F

G

H

I

1

PART

DESCRIPTION

UNIT

PLAN

ARTICLE

QOH

BOL SHIP QTY

SERIAL COUNT

QC Notes

2

JAR0488801

1

PC

a

26140410

6

0

1

3

JAR0489701

2

PC

a

26180767

252

0

2

4

JAR0533001

3

PC

a

26226984

432

0

1

5

JAR0537801

4

PC

a

26234494

180

0

1

6

JAR0540901

5

PC

a

26182162

516

0

2

7

JAR0562001

6

PC

a

26154558

498

0

2

8

JAR0583501

7

PC

a

26385667

132

0

1

9

JAR0584001

8

PC

a

26385189

54

0

1

10

JAR0584701

9

PC

a

26383987

42

0

1

11

JAR0588401

10

PC

a

26390558

4518

0

12

JAR0591701

11

PC

a

26388309

528

0

2

13

JAR0594001

12

PC

a

26438563

42

0

1

14

JAR0594501

13

PC

a

26410259

23064

50

15

JAR0596101

14

PC

a

26410865

642

3

16

JAR0596301

15

PC

a

26410278

522

0

2

17

JAR0598101

16

PC

a

26191832

396

0

1

18

JAR0599001

17

PC

a

26480787

5316

14

19

JAR0599801

18

PC

a

26459578

25920

20640

54

20

JAR0599901

19

PC

a

26459586

59220

21120

134

21

JAR0600001

20

PC

a

26426981

12992

16

22

JAR0600101

21

PC

a

26426978

7184

7488

8

23

JAR0600301

22

PC

a

26426982

14176

16

24

JAR0601101

23

PC

a

26437386

688

4

25

JAR0601701

24

PC

a

26438505

29432

37

26

JAR0602501

25

PC

a

26441609

121440

78720

263

27

JAR0602701

26

PC

a

26441613

47844

0

120

28

JAR0602901

27

PC

a

26441612

104700

84000

229

29

JAR0603101

28

PC

a

26441624

108876

82368

228

30

JAR0604001

29

PC

a

26439848

50118

50184

105

31

JAR0604101

30

PC

a

26439400

44298

0

93

FP burn - started 1/2/22

32

JAR0604401

31

PC

a

26448743

14792

0

16

33

JAR0604601

32

PC

a

26439848

51576

31896

108

34

JAR0605001

33

PC

a

26448735

7104

0

8

35

JAR0605401

34

PC

a

26448733

46784

43056

51

36

JAR0607001

35

PC

a

26448740

54768

0

64

Yesterday

Sheet 2

logistics shipping playground.xlsm

A

B

C

D

E

F

G

H

I

1

PART

DESCRIPTION

UNIT

PLAN

ARTICLE

QOH

BOL SHIP QTY

SERIAL COUNT

QC Notes

2

JAR0488801

1

PC

a

26140410

6

0

1

3

JAR0489701

2

PC

a

26180767

252

0

2

4

JAR0533001

3

PC

a

26226984

432

0

1

5

JAR0537801

4

PC

a

26234494

180

0

1

6

JAR0540901

5

PC

a

26182162

516

0

2

7

JAR0562001

6

PC

a

26154558

498

0

2

8

JAR0583501

7

PC

a

26385667

132

0

1

9

JAR0584001

8

PC

a

26385189

54

0

1

10

JAR0584701

9

PC

a

26383987

42

0

1

11

JAR0588401

10

PC

a

26390558

4518

0

12

JAR0591701

11

PC

a

26388309

528

0

2

13

JAR0594001

12

PC

a

26438563

42

0

1

14

JAR0594501

13

PC

a

26410259

15360

33

15

JAR0596301

14

PC

a

26410278

522

0

2

16

JAR0598101

15

PC

a

26191832

396

0

1

17

JAR0599001

16

PC

a

26480787

2880

6

18

JAR0599801

17

PC

a

26459578

22560

47

19

JAR0599901

18

PC

a

26459586

72048

52800

151

20

JAR0600001

19

PC

a

26426981

12992

16

21

JAR0600101

20

PC

a

26426978

7184

7488

8

22

JAR0600301

21

PC

a

26426982

14176

16

23

JAR0601101

22

PC

a

26437386

688

4

24

JAR0601701

23

PC

a

26438505

29016

36

25

JAR0602501

24

PC

a

26441609

102828

87360

215

26

JAR0602701

25

PC

a

26441613

102408

47040

215

27

JAR0602901

26

PC

a

26441612

74892

67680

157

28

JAR0603101

27

PC

a

26441624

75948

75840

159

29

JAR0604001

28

PC

a

26439848

32838

69

30

JAR0604101

29

PC

a

26439400

44298

0

93

31

JAR0604401

30

PC

a

26448743

14792

16

32

JAR0604601

31

PC

a

26439848

51576

51162

108

33

JAR0605001

32

PC

a

26448735

7104

8

34

JAR0605401

33

PC

a

26448733

41168

45

35

JAR0607001

34

PC

a

26448740

72408

54288

78

Today

Sheet 3

logistics shipping playground.xlsm

A

B

C

D

E

F

G

H

I

J

K

L

M

N

O

P

Q

R

S

T

5

Yesterday

Today

6

JAR0488801

1

PC

a

26140410

6

0

1

0

JAR0488801

1

PC

a

26140410

6

0

1

0

7

JAR0489701

2

PC

a

26180767

252

0

2

0

JAR0489701

2

PC

a

26180767

252

0

2

0

8

JAR0533001

3

PC

a

26226984

432

0

1

0

JAR0533001

3

PC

a

26226984

432

0

1

0

9

JAR0537801

4

PC

a

26234494

180

0

1

0

JAR0537801

4

PC

a

26234494

180

0

1

0

10

JAR0540901

5

PC

a

26182162

516

0

2

0

JAR0540901

5

PC

a

26182162

516

0

2

0

11

JAR0562001

6

PC

a

26154558

498

0

2

0

JAR0562001

6

PC

a

26154558

498

0

2

0

12

JAR0583501

7

PC

a

26385667

132

0

1

0

JAR0583501

7

PC

a

26385667

132

0

1

0

13

JAR0584001

8

PC

a

26385189

54

0

1

0

JAR0584001

8

PC

a

26385189

54

0

1

0

14

JAR0584701

9

PC

a

26383987

42

0

1

0

JAR0584701

9

PC

a

26383987

42

0

1

0

15

JAR0588401

10

PC

a

26390558

4518

0

12

0

JAR0588401

10

PC

a

26390558

4518

0

12

0

16

JAR0591701

11

PC

a

26388309

528

0

2

0

JAR0591701

11

PC

a

26388309

528

0

2

0

17

JAR0594001

12

PC

a

26438563

42

0

1

0

JAR0594001

12

PC

a

26438563

42

0

1

0

18

JAR0594501

13

PC

a

26410259

23064

50

0

JAR0594501

13

PC

a

26410259

15360

33

0

19

JAR0596301

15

PC

a

26410278

522

0

2

0

JAR0596301

14

PC

a

26410278

522

0

2

0

20

JAR0598101

16

PC

a

26191832

396

0

1

0

JAR0598101

15

PC

a

26191832

396

0

1

0

21

JAR0599001

17

PC

a

26480787

5316

14

0

JAR0599001

16

PC

a

26480787

2880

6

0

22

JAR0599801

18

PC

a

26459578

25920

20640

54

0

JAR0599801

17

PC

a

26459578

22560

47

0

23

JAR0599901

19

PC

a

26459586

59220

21120

134

0

JAR0599901

18

PC

a

26459586

72048

52800

151

0

24

JAR0600001

20

PC

a

26426981

12992

16

0

JAR0600001

19

PC

a

26426981

12992

16

0

25

JAR0600101

21

PC

a

26426978

7184

7488

8

0

JAR0600101

20

PC

a

26426978

7184

7488

8

0

26

JAR0600301

22

PC

a

26426982

14176

16

0

JAR0600301

21

PC

a

26426982

14176

16

0

27

JAR0601101

23

PC

a

26437386

688

4

0

JAR0601101

22

PC

a

26437386

688

4

0

28

JAR0601701

24

PC

a

26438505

29432

37

0

JAR0601701

23

PC

a

26438505

29016

36

0

29

JAR0602501

25

PC

a

26441609

1E+05

78720

263

0

JAR0602501

24

PC

a

26441609

102828

87360

215

0

30

JAR0602701

26

PC

a

26441613

47844

0

120

0

JAR0602701

25

PC

a

26441613

102408

47040

215

0

31

JAR0602901

27

PC

a

26441612

1E+05

84000

229

0

JAR0602901

26

PC

a

26441612

74892

67680

157

0

32

JAR0603101

28

PC

a

26441624

1E+05

82368

228

0

JAR0603101

27

PC

a

26441624

75948

75840

159

0

33

JAR0604001

29

PC

a

26439848

50118

50184

105

0

JAR0604001

28

PC

a

26439848

32838

69

0

34

JAR0604101

30

PC

a

26439400

44298

0

93

FP burn - started 1/2/22

JAR0604101

29

PC

a

26439400

44298

0

93

0

35

JAR0604401

31

PC

a

26448743

14792

0

16

0

JAR0604401

30

PC

a

26448743

14792

16

0

36

JAR0604601

32

PC

a

26439848

51576

31896

108

0

JAR0604601

31

PC

a

26439848

51576

51162

108

0

37

JAR0605001

33

PC

a

26448735

7104

0

8

0

JAR0605001

32

PC

a

26448735

7104

8

0

38

JAR0605401

34

PC

a

26448733

46784

43056

51

0

JAR0605401

33

PC

a

26448733

41168

45

0

39

JAR0607001

35

PC

a

26448740

54768

0

64

0

JAR0607001

34

PC

a

26448740

72408

54288

78

0

Filter

Cell Formulas
Range	Formula
A6:A40	A6	=SORT(UNIQUE(LET(r,ROWS(Table1),s,SEQUENCE(r+ROWS(Table2)),IFERROR(INDEX(#REF!,s),INDEX(Table2[PART],s-r)))))
B6:J39	B6	=FILTER(Table1,Table1[PART]=$A6,"")
L6:T39	L6	=FILTER(Table2,Table2[PART]=$A6,"")
Dynamic array formulas.

Alex Blakenburg · Jan 7, 2022

Afro_Cookie said:
There is a bug that is causing merged cells to unmerge and shifting my data on my 'Filtered' sheet, which I don't understand as the piece of code isn't interacting with that sheet. I tried running the piece of code on its own and there were no errors.

error generated at this point when entire code is run

VBA Code:

'copying the 'QC info' data from 'yesterday' to 'today' Sheets("Yesterday").Range("Table1[QC Notes]").Copy Sheets("Today").Range("I2")

The error is not on the line you are indicacting but the line prior to that shown below and
that line is in fact interacting with the Filter sheet.

Especially when you are dealing with mulitple sheets it is preferable not to rely on a sheet being the ActiveSheet and specifying your references.

The below line looks to be Back to front. Presumably you are intending to copy from the Filter sheet to the Today sheet.
Range("A2") refers to the ActiveSheet which at this point is the Filter sheet. So if you didn't want to set variables for the sheets it would be better if you used Sheets("Filter").Range("A2").
It still looks back to front to me. The syntax is RangeFROM.Cut RangeTO

VBA Code:

    'overrighting current table data with the newly filtered data  <---- XXX I think you meant Overwriting XXX
    Sheets("Today").Range("K2").CurrentRegion.Offset(1, 0).Cut Range("A2")

Afro_Cookie · Jan 7, 2022

Alex Blakenburg said:
The error is not on the line you are indicacting but the line prior to that shown below and
that line is in fact interacting with the Filter sheet.

Especially when you are dealing with mulitple sheets it is preferable not to rely on a sheet being the ActiveSheet and specifying your references.

The below line looks to be Back to front. Presumably you are intending to copy from the Filter sheet to the Today sheet.
Range("A2") refers to the ActiveSheet which at this point is the Filter sheet. So if you didn't want to set variables for the sheets it would be better if you used Sheets("Filter").Range("A2").
It still looks back to front to me. The syntax is RangeFROM.Cut RangeTO

VBA Code:

'overrighting current table data with the newly filtered data <---- XXX I think you meant Overwriting XXX Sheets("Today").Range("K2").CurrentRegion.Offset(1, 0).Cut Range("A2")

thanks for the typo correction. You're right about the active sheet reference. I modified the code to show the sheet I wanted the data to paste to and it corrected itself.

VBA Code:

    'old code that generated the error
    Sheets("Today").Range("K2").CurrentRegion.Offset(1, 0).Cut Range("A2")
    
   'modified code to eliminate error
    Sheets("Today").Range("K2").CurrentRegion.Offset(1, 0).Cut Sheet("Today").Range("A2")

Alex Blakenburg · Jan 7, 2022

Thanks for the update. Is it doing what it is supposed to now ?

Afro_Cookie · Jan 10, 2022

Alex Blakenburg said:
Thanks for the update. Is it doing what it is supposed to now ?

After I specified the specific sheet I wanted to copy to, it is. Below is the final, updated code that works without a hitch. I know it's not the prities, but it works well for my current needs. If anyone reading this has ideas on how to streamline it further, I'm all eyes.

VBA Code:

Sub ColourMeElmo()

Application.ScreenUpdating = False

'establish the criteria for colouring cells
Dim i As Long, r1 As Range, r2 As Range

'code for selecting which cells get coloured backgrounds
   Sheets("Filter").Select
   On Error Resume Next
   For i = 6 To 41
      Set r1 = Range("B" & i)
      Set r2 = Range("L" & i & ":S" & i)
      If r1.Value = "" Then r2.Interior.Color = vbYellow
   Next i

' For "Receive" data that gets copied, pasted into the 'Receive' sheet from 'Filter', after formatting has taken place
    ActiveSheet.Range("L6", ActiveSheet.Range("L6").End(xlDown).End(xlToRight)).Copy
    Sheets("Receive").Range("K2").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Receive").Range("K2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
          
' For "Send" data that gets copied, pasted into the 'Send' sheet from 'fileter', after formatting has taken place
    Sheets("Filter").Range("B6", ActiveSheet.Range("B6").End(xlDown).End(xlToRight)).Copy
    Sheets("Send").Range("A2").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Send").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'overwrighting current table data with the newly filtered data
    Sheets("Receive").Range("K2").CurrentRegion.Cut Sheets("Receive").Range("A2")

'copying the 'QC info' data from 'Send' to 'Receive'
    Sheets("Send").Range("Table1[QC Notes]").Copy Sheets("Receive").Range("I2")
        
'Deleting blank rows in table
    Sheets("Receive").Select
    ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=1, Criteria1:="="
    ActiveSheet.AutoFilter.Range.Offset(1).Delete
    ActiveSheet.ListObjects("Table2").Range.AutoFilter Field:=1

'delete all rows from 'Send' table
    Sheets("Send").Select
        If Not ActiveCell.ListObject Is Nothing Then
            ActiveCell.ListObject.DataBodyRange.Delete
        End If
        
'transfer data from 'Receive' to 'Send'
    Sheets("Receive").Range("A2").CurrentRegion.Offset(1, 0).Copy
    Sheets("Send").Range("A2").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Send").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
'reset sheets
    Sheets("Send").Columns("J:S").EntireColumn.Delete
    Sheets("Filter").Range("A:T").Interior.Color = xlNone
        
'delete all rows from 'Receive' table
    Sheets("Receive").Select
    Range("A2").Select
        If Not ActiveCell.ListObject Is Nothing Then
            ActiveCell.ListObject.DataBodyRange.Delete
        End If
        
'go to main sheet
    Sheets("Send").Select
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="="
    ActiveSheet.AutoFilter.Range.Offset(1).Delete
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1
    
    Call Hulk 'Format cells, spacing alignment, box border removal, font and size standardization. Nothing too interesting in here.
    
Application.ScreenUpdating = True

End Sub

Alex Blakenburg · Jan 11, 2022

I have not tested this since you have renamed sheets I am not sure if the initial XL2BBs still apply, so make sure you take a copy of your workbook first.
Also there is a always some personal preference involved but see if this helps.
Essentially

Removed all references to the following: Select, ActiveSheet, ActiveCell
Note: You had an ActiveCell reference on the Send sheet without any Cell being selected in the code. I have assumed it was meant to be "A2"
Used set command so the sheet names are defined at the top, so you only have one change to make if you change the sheet names again.
Used With / End With - more efficient and clearer.

VBA Code:

Sub ColourMeElmo_AB()

Application.ScreenUpdating = False

'establish the criteria for colouring cells
Dim i As Long, r1 As Range, r2 As Range
Dim shtFltr As Worksheet, shtRec As Worksheet, shtSend As Worksheet

Set shtFltr = Sheets("Filter")
Set shtRec = Sheets("Receive")
Set shtSend = Sheets("Send")

'code for selecting which cells get coloured backgrounds
   On Error Resume Next
   For i = 6 To 41
      With shtFltr
          Set r1 = .Range("B" & i)
          Set r2 = .Range("L" & i & ":S" & i)
      End With
      If r1.Value = "" Then r2.Interior.Color = vbYellow
   Next i

' For "Receive" data that gets copied, pasted into the 'Receive' sheet from 'Filter', after formatting has taken place
    With shtFltr
        .Range("L6", .Range("L6").End(xlDown).End(xlToRight)).Copy
    End With
    
    With shtRec.Range("K2")
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
          
' For "Send" data that gets copied, pasted into the 'Send' sheet from 'fileter', after formatting has taken place
    With shtFltr
        .Range("B6", .Range("B6").End(xlDown).End(xlToRight)).Copy
    End With
    
    With shtSend.Range("A2")
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With

' overwriting current table data with the newly filtered data
    With shtRec
        .Range("K2").CurrentRegion.Cut .Range("A2")
    End With

'copying the 'QC info' data from 'Send' to 'Receive'
    With shtSend
        .Range("Table1[QC Notes]").Copy Destination:=.Range("I2")
    End With
        
'Deleting blank rows in table
    With shtRec
        .ListObjects("Table2").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table2").Range.AutoFilter Field:=1
    End With

'delete all rows from 'Send' table
    With shtSend.Range("A2")                            ' <--- Check that this is meant to be "A2"
        If Not .ListObject Is Nothing Then
            .ListObject.DataBodyRange.Delete
        End If
    End With
        
'transfer data from 'Receive' to 'Send'
    shtRec.Range("A2").CurrentRegion.Offset(1, 0).Copy
    With shtSend.Range("A2")
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
    
'reset sheets
    shtSend.Columns("J:S").EntireColumn.Delete
    shtFltr.Range("A:T").Interior.Color = xlNone
        
'delete all rows from 'Receive' table
    With shtRec.Range("A2")
        If Not .ListObject Is Nothing Then
            .ListObject.DataBodyRange.Delete
        End If
    End With
        
'go to main sheet
    With shtSend
        .ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table1").Range.AutoFilter Field:=1
    End With
    
    Call Hulk 'Format cells, spacing alignment, box border removal, font and size standardization. Nothing too interesting in here.
    
Application.ScreenUpdating = True

End Sub

Afro_Cookie · Jan 11, 2022

Alex Blakenburg said:

I have not tested this since you have renamed sheets I am not sure if the initial XL2BBs still apply, so make sure you take a copy of your workbook first.
Also there is a always some personal preference involved but see if this helps.
Essentially

Removed all references to the following: Select, ActiveSheet, ActiveCell
Note: You had an ActiveCell reference on the Send sheet without any Cell being selected in the code. I have assumed it was meant to be "A2"
Used set command so the sheet names are defined at the top, so you only have one change to make if you change the sheet names again.
Used With / End With - more efficient and clearer.

VBA Code:

Sub ColourMeElmo_AB()

Application.ScreenUpdating = False

'establish the criteria for colouring cells
Dim i As Long, r1 As Range, r2 As Range
Dim shtFltr As Worksheet, shtRec As Worksheet, shtSend As Worksheet

Set shtFltr = Sheets("Filter")
Set shtRec = Sheets("Receive")
Set shtSend = Sheets("Send")

'code for selecting which cells get coloured backgrounds
   On Error Resume Next
   For i = 6 To 41
      With shtFltr
          Set r1 = .Range("B" & i)
          Set r2 = .Range("L" & i & ":S" & i)
      End With
      If r1.Value = "" Then r2.Interior.Color = vbYellow
   Next i

' For "Receive" data that gets copied, pasted into the 'Receive' sheet from 'Filter', after formatting has taken place
    With shtFltr
        .Range("L6", .Range("L6").End(xlDown).End(xlToRight)).Copy
    End With
   
    With shtRec.Range("K2")
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
         
' For "Send" data that gets copied, pasted into the 'Send' sheet from 'fileter', after formatting has taken place
    With shtFltr
        .Range("B6", .Range("B6").End(xlDown).End(xlToRight)).Copy
    End With
   
    With shtSend.Range("A2")
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With

' overwriting current table data with the newly filtered data
    With shtRec
        .Range("K2").CurrentRegion.Cut .Range("A2")
    End With

'copying the 'QC info' data from 'Send' to 'Receive'
    With shtSend
        .Range("Table1[QC Notes]").Copy Destination:=.Range("I2")
    End With
       
'Deleting blank rows in table
    With shtRec
        .ListObjects("Table2").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table2").Range.AutoFilter Field:=1
    End With

'delete all rows from 'Send' table
    With shtSend.Range("A2")                            ' <--- Check that this is meant to be "A2"
        If Not .ListObject Is Nothing Then
            .ListObject.DataBodyRange.Delete
        End If
    End With
       
'transfer data from 'Receive' to 'Send'
    shtRec.Range("A2").CurrentRegion.Offset(1, 0).Copy
    With shtSend.Range("A2")
        .PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    End With
   
'reset sheets
    shtSend.Columns("J:S").EntireColumn.Delete
    shtFltr.Range("A:T").Interior.Color = xlNone
       
'delete all rows from 'Receive' table
    With shtRec.Range("A2")
        If Not .ListObject Is Nothing Then
            .ListObject.DataBodyRange.Delete
        End If
    End With
       
'go to main sheet
    With shtSend
        .ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table1").Range.AutoFilter Field:=1
    End With
   
    Call Hulk 'Format cells, spacing alignment, box border removal, font and size standardization. Nothing too interesting in here.
   
Application.ScreenUpdating = True

End Sub

Hi Alex, Thanks for looking at this.

I did change the sheet names from 'Yesterday' to 'Send' and 'Today' to 'Receive'.

I took a lot of what you modified and added it to my own code but there are two parts of your modification that I left in its original form as I actually did want the sheets selected and I needed to transfer data from one sheet to the next.

Transfer from one sheet to the next.

VBA Code:

'copying the 'QC info' data from 'Send' to 'Receive'          <------ Destination needs to be 'shtRec' Range("I2").
    With shtSend
        .Range("Table1[QC Notes]").Copy Destination:=.Range("I2")
    End With

'go to main sheet           <----added the select 'shtSend' command back in as that is the final sheet I want to end up viewing.
    With shtSend
        .ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table1").Range.AutoFilter Field:=1
    End With

Alex Blakenburg · Jan 11, 2022

In that case:-
Change Item 1 to

VBA Code:

'copying the 'QC info' data from 'Send' to 'Receive'          <------ Destination needs to be 'shtRec' Range("I2").
shtSend.Range("Table1[QC Notes]").Copy Destination:=shtRec.Range("I2")

FOr Item 2 - Just finish with a select at the end of the code and leave what I had.

VBA Code:

    With shtSend
        .ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table1").Range.AutoFilter Field:=1
    End With

'go to main sheet           <----added the select 'shtSend' command back in as that is the final sheet I want to end up viewing.
shtSend.Select
shtSend.Range("A2").Select

Afro_Cookie · Jan 11, 2022

Alex Blakenburg said:

In that case:-
Change Item 1 to

VBA Code:

'copying the 'QC info' data from 'Send' to 'Receive'          <------ Destination needs to be 'shtRec' Range("I2").
shtSend.Range("Table1[QC Notes]").Copy Destination:=shtRec.Range("I2")

FOr Item 2 - Just finish with a select at the end of the code and leave what I had.

VBA Code:

    With shtSend
        .ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:="="
        .AutoFilter.Range.Offset(1).Delete
        .ListObjects("Table1").Range.AutoFilter Field:=1
    End With

'go to main sheet           <----added the select 'shtSend' command back in as that is the final sheet I want to end up viewing.
shtSend.Select
shtSend.Range("A2").Select

Works. Thanks Alex.

Alex Blakenburg · Jan 11, 2022

Thanks for letting me know. Glad I could help.

error generated in complete code but when run on its own.

Afro_Cookie

Board Regular

Excel Facts

Alex Blakenburg

MrExcel MVP

Afro_Cookie

Board Regular

Alex Blakenburg

MrExcel MVP

Afro_Cookie

Board Regular

Alex Blakenburg

MrExcel MVP

Afro_Cookie

Board Regular

Alex Blakenburg

MrExcel MVP

Afro_Cookie

Board Regular

Alex Blakenburg

MrExcel MVP

Similar threads

Forum statistics

Share this page

error generated in complete code but when run on its own.

Board Regular

Excel Facts

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock