Macro Help - Unable to decipher!

RossShep92

New Member
Joined
Jan 20, 2020
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
Hi

I have taken ownership of some spreadsheets, but the macro seems to not be working in one file as it normally does it multiple other files.

I can normally decipher whats wrong in them, but this one is stumping me.

The code is below and the text in bold & red is where it is getting stuck. the macro is filtering on an external spreadsheet relating to the criteria detailed, then copying and pasting into another spreadsheet by month.
Rich (BB code):
Sub NewData()

Dim pCount As Integer, i As Integer, j As Integer, rCount As Integer

For j = 1 To UBound(ACList())
    Tracker.Sheets(ACList(j)).Activate

    DataSheet.Activate
    With ActiveSheet
        .AutoFilterMode = False
        With .Range("A1")
            .AutoFilter
            .AutoFilter Field:=2, Criteria1:="*19215*"
            .AutoFilter Field:=8, Criteria1:="*" & BU & "*"
            .AutoFilter Field:=3, Criteria1:="*" & ACList(j) & "*"
        End With
        .Range("D2").Select
    End With
  
    If ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 = 0 Then
        GoTo NoAccData
    End If
  
    Range(Selection, Selection.End(xlDown)).Resize(, 4).Copy
    Tracker.Sheets(ACList(j)).Activate
    Range("A61").PasteSpecial xlPasteValues
    DataSheet.Activate
    Range("B2").Select
    Range(Selection, Selection.End(xlDown)).Copy
    Tracker.Sheets(ACList(j)).Activate
    Range("E61").PasteSpecial xlPasteValues
    If Range("A61").Offset(1, 0).Value = "" Then
        pCount = Range("A61").Value
    Else
        pCount = Range("A61").End(xlDown).Value * 1
    End If
  
    rCount = 61
    For i = 1 To pCount
        DataSheet.Activate
        Range("A1").AutoFilter Field:=4, Criteria1:=i
        Range("I2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        Tracker.Sheets(ACList(j)).Activate
        Cells(rCount, i + 5).PasteSpecial xlPasteValues
        DataSheet.Activate
        Range("I1").Select
        rCount = rCount + WorksheetFunction.Subtotal(3, Range(Selection, Selection.End(xlDown))) - 1
    Next
  
NoAccData:
Next

End Sub


The below is the data that is held externally that is copied and pasted

1608546498725.png


The below is the tab (split by object account code) that it should paste in to. It seems to get stuck at the paste value part of it as the information populates, but not the amount.

1608546614777.png


Any help appreciated

Thanks,
Ross
 
Last edited by a moderator:

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
37,146
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
Do you get an error?
 

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
37,146
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
Try changing this section:

Code:
    For i = 1 To pCount
        DataSheet.Activate
        Range("A1").AutoFilter Field:=4, Criteria1:=i
        Range("I2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        Tracker.Sheets(ACList(j)).Activate
        Cells(rCount, i + 5).PasteSpecial xlPasteValues
        DataSheet.Activate
        Range("I1").Select
        rCount = rCount + WorksheetFunction.Subtotal(3, Range(Selection, Selection.End(xlDown))) - 1
    Next

to this:

Code:
    For i = 1 To pCount
        With DataSheet
            .Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=i
            If .Range("A1").CurrentRegion.Columns(1).SpecialCells(xlcelltypevisible).count > 1 then
               with .Range("I2", .Cells(.Rows.Count, "I").End(xlUp))
                   .Copy
                   Tracker.Sheets(ACList(j)).Cells(rCount, i + 5).PasteSpecial xlPasteValues
                   rCount = rCount + WorksheetFunction.Subtotal(3, .Cells)
               End With
            End If
        End With
    Next
 

RossShep92

New Member
Joined
Jan 20, 2020
Messages
7
Office Version
  1. 2019
Platform
  1. Windows
Try changing this section:

Code:
    For i = 1 To pCount
        DataSheet.Activate
        Range("A1").AutoFilter Field:=4, Criteria1:=i
        Range("I2").Select
        Range(Selection, Selection.End(xlDown)).Copy
        Tracker.Sheets(ACList(j)).Activate
        Cells(rCount, i + 5).PasteSpecial xlPasteValues
        DataSheet.Activate
        Range("I1").Select
        rCount = rCount + WorksheetFunction.Subtotal(3, Range(Selection, Selection.End(xlDown))) - 1
    Next

to this:

Code:
    For i = 1 To pCount
        With DataSheet
            .Range("A1").CurrentRegion.AutoFilter Field:=4, Criteria1:=i
            If .Range("A1").CurrentRegion.Columns(1).SpecialCells(xlcelltypevisible).count > 1 then
               with .Range("I2", .Cells(.Rows.Count, "I").End(xlUp))
                   .Copy
                   Tracker.Sheets(ACList(j)).Cells(rCount, i + 5).PasteSpecial xlPasteValues
                   rCount = rCount + WorksheetFunction.Subtotal(3, .Cells)
               End With
            End If
        End With
    Next
Hi again,

Sorry to come back to this!

It has now come up with the below error message when attempting this.


I have managed to expand the error message that the original code was getting to, and its saying the below if that helps!

Thanks,
Ross
 

Attachments

  • 1610462357593.png
    1610462357593.png
    11.7 KB · Views: 2
  • 1610462431502.png
    1610462431502.png
    8.3 KB · Views: 3

RoryA

MrExcel MVP, Moderator
Joined
May 2, 2008
Messages
37,146
Office Version
  1. 365
  2. 2019
  3. 2016
  4. 2010
Platform
  1. Windows
  2. MacOS
Which of those two errors are you getting now, and on which line?
 

Forum statistics

Threads
1,136,864
Messages
5,678,216
Members
419,752
Latest member
TryingtoLearnVBA

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top