nniedzielski
Well-known Member
- Joined
- Jan 8, 2016
- Messages
- 598
- Office Version
- 2019
- Platform
- Windows
I have the below macro, and on the line in red, the sheet will not copy. I am getting an error that says subscript is out of range, i cant seem to get it to copy.
Worksheets(xCar).Copy After:=Worksheets("Sheet1")
Worksheets(xCar).Copy After:=Worksheets("Sheet1")
VBA Code:
Sub loopFilter()
Sheets("Data").Select
Dim erow As Long
erow = ActiveSheet.Cells(Rows.Count, 10).End(xlUp).Row
Range("K1:K" & erow).Copy
Range("AD1:AD" & erow).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
ActiveSheet.Range("$AD$1:$AD$10000").RemoveDuplicates Columns:=1, Header:=xlYes
Dim ArrayDictionaryofItems As Object, Items As Variant, i As Long, Item As Variant
Dim x As Double
Set ArrayDictionaryofItems = CreateObject("Scripting.Dictionary")
With ActiveSheet
If Not .AutoFilterMode Then .UsedRange.AutoFilter
If .Cells.AutoFilter Then .Cells.AutoFilter
Items = .Range(.Range("AD2"), .Cells(Rows.Count, "AD").End(xlUp))
For i = 1 To UBound(Items, 1)
ArrayDictionaryofItems(Items(i, 1)) = 1
Next i
x = 2
For Each xCar In ArrayDictionaryofItems.keys
Sheets("Data").UsedRange.AutoFilter field:=11, Criteria1:=xCar
Sheets.Add(Before:=Sheets(1)).Name = xCar
Sheets("Data").Select
Range("A1" & ":" & "Y" & erow).SpecialCells(xlCellTypeVisible).Copy
Sheets(xCar).Range("A1" & ":" & "Y1").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
'create attachment
Dim sFilename As String
sFilename = ThisWorkbook.Path & "\SCACMacro.xlsx"
' Add a new workbook
Dim wkTemp As Workbook
Set wkTemp = Workbooks.Add
' Copy the worksheet and delete the default
[COLOR=rgb(184, 49, 47)]Worksheets(xCar).Copy After:=Worksheets("Sheet1")[/COLOR]
' turn off alerts before delete worksheet
Application.DisplayAlerts = False
wkTemp.Worksheets(1).Delete
Application.DisplayAlerts = True
' Save the new workbook
wkTemp.SaveAs sFilename
wkTemp.Close
x = x + 1
Next xCar
End With
End Sub