Type Mismatch-Macro to Extract Data from specific Sheets

[howard]

I have the following macro below to extract inventory from sheets "Shirts", "Trousers" and "Shoes" based on criteria on sheet "Overaged Inventory" in Cells Aa1:Aa2

I get a type mismatch and code below is highlighted

  Sheets(ws).Range("A1:K2000").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("AA1:AA2"), CopyToRange:=Range("A1"), Unique:=False

 Sub Extract_Overaged()

Dim ws  As Worksheet

Application.ScreenUpdating = False
 
   For Each ws In Sheets(Array("Shirts", "Trousers", "Shoes"))
   Sheets("Overaged Inventory").Select

   
    Sheets(ws).Range("A1:K2000").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("AA1:AA2"), CopyToRange:=Range("A1"), Unique:=False
    Next ws
Application.ScreenUpdating = True

 
End Sub

It would be appreciated if someone could kindly amend my code

 

[Micron]

You've declared ws as an object and I'm thinking it cannot be used as a reference to the Sheets collection - Sheets(ws).
If I change that to ws.Range("A1:K2000") then that error goes away but raises a different one, so it seems you have more than one issue. Either that or it's because even when I modify it so I can at least run it, I'm missing something that you have in your wb.

 

[HaHoBe]

Hi howard,

you could omit using the array as the data from the last sheet would overwrite when always starting in A1:

Sub Extract_Overaged_mod()

Dim ws As Worksheet
Dim wsOver As Worksheet

Application.ScreenUpdating = False
Set wsOver = Worksheets("Overaged Inventory")

For Each ws In Sheets(Array("Shirts", "Trousers", "Shoes"))
  ws.Range("A1:K2000").AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=wsOver.Range("AA1:AA2"), CopyToRange:=wsOver.Range("A1"), Unique:=False
Next ws
Set wsOver = Nothing

Application.ScreenUpdating = True

End Sub

Adding (headers will get filtered as well) under the contents leaving one row empty:

Sub Extract_Overaged_Adding()

Dim ws As Worksheet
Dim wsOver As Worksheet

Application.ScreenUpdating = False
Set wsOver = Worksheets("Overaged Inventory")

For Each ws In Sheets(Array("Shirts", "Trousers", "Shoes"))
  ws.Range("A1:K2000").AdvancedFilter Action:=xlFilterCopy, _
      CriteriaRange:=wsOver.Range("AA1:AA2"), CopyToRange:=wsOver.Cells(wsOver.Rows.Count, "A").End(xlUp).Offset(2, 0), Unique:=False
Next ws
Set wsOver = Nothing

Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[howard]

Many thanks for the help Holger

Your code works perfectly

 

[HaHoBe]

Hi howard,

a reworked code for the target sheet: contents in Column A to K will be cleared, data transferred, I assumed the headers for each sheet to be identical so a range is build in order to delete the empty cells in the datafield as well as the additional headers for sheet 2 and 3:

Sub Extract_Overaged_mod2()

Dim ws As Worksheet
Dim wsOver As Worksheet
Dim rngDel As Range
Dim rngWork As Range
Dim rngArea As Range

Application.ScreenUpdating = False
Set wsOver = Worksheets("Overaged Inventory")
'delete contents in target sheet in Columns A to K
wsOver.Range("A1:K1").EntireColumn.ClearContents

For Each ws In Sheets(Array("Shirts", "Trousers", "Shoes"))
  ws.Range("A1:K" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=wsOver.Range("AA1:AA2"), _
        CopyToRange:=wsOver.Cells(wsOver.Rows.Count, "A").End(xlUp).Offset(2, 0), _
        Unique:=False
Next ws

'build a range on empty cells in Column A
On Error Resume Next
With wsOver
  Set rngWork = .Range("A3:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
  Set rngWork = Union(rngWork, .Range("A3:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).Offset(1, 0))
  Set rngWork = Union(rngWork, .Range("A1:A2"))
  'if we have a range resize each rngArea to cover Columns A to K
  If Not rngWork Is Nothing Then
    For Each rngArea In rngWork
      If rngDel Is Nothing Then
        Set rngDel = rngArea.Resize(1, 11)
      Else
        Set rngDel = Union(rngDel, rngArea.Resize(1, 11))
      End If
    Next rngArea
    'delete the empty areas and shift cells up
    rngDel.Delete
  End If
End With

'release objects
Set rngDel = Nothing
Set rngWork = Nothing
Set wsOver = Nothing

Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[howard]

Many thanks for the updated code