Nothing has change so why do I get : Sort method of range class failed.

[Romano_odK]

Good afternoon,

The below code was working fine last year and in the meanwhile nothing has changed expect the domain where I am working in. Can someone tell me why I get this error? "Sort method of range class failed"

Thank you for your time and all the best wishes for 2024.

Private Sub FilterOK_Click()
  Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
 
  nc = Range("ItemsImport").Columns.Count + 1
  a = Range("ItemsImport[[#All],[Afwijking %" & Chr(10) & "Opslag]]").Value
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If LCase(a(i, 1)) = "ok" Or Len(a(i, 1)) = 0 Then
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("ItemsImport[#All]").Resize(, nc)
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlYes
      .Offset(1).Resize(k).EntireRow.Delete
      .Columns(nc).EntireColumn.Delete
    End With
    Application.ScreenUpdating = True
  End If
End Sub

 

[jkpieterse]

Are you sure nothing has changed? Is the named range ItemsImport pointing to where you expect it to point to?

 

[DanteAmor]

Works for me.

But try this other approach:

Private Sub FilterOK_Click()
  Dim tbl As ListObject
  Dim col As ListColumn
  Dim fnd As Range
 
  Set tbl = ActiveSheet.ListObjects("ItemsImport")
  Set col = tbl.ListColumns("Afwijking %" & Chr(10) & "Opslag")
  Set fnd = col.Range.Find("ok", , xlValues, xlWhole, , , False)
 
  Application.ScreenUpdating = False
  If Not fnd Is Nothing Then
    tbl.Range.AutoFilter col.Index, "ok"
    tbl.DataBodyRange.EntireRow.Delete
    ActiveSheet.ShowAllData
  End If
  Application.ScreenUpdating = True
End Sub

 

[Romano_odK]

Works for me.

But try this other approach:

Private Sub FilterOK_Click()
  Dim tbl As ListObject
  Dim col As ListColumn
  Dim fnd As Range
 
  Set tbl = ActiveSheet.ListObjects("ItemsImport")
  Set col = tbl.ListColumns("Afwijking %" & Chr(10) & "Opslag")
  Set fnd = col.Range.Find("ok", , xlValues, xlWhole, , , False)
 
  Application.ScreenUpdating = False
  If Not fnd Is Nothing Then
    tbl.Range.AutoFilter col.Index, "ok"
    tbl.DataBodyRange.EntireRow.Delete
    ActiveSheet.ShowAllData
  End If
  Application.ScreenUpdating = True
End Sub

Now I get script out of range.

Works for me.

But try this other approach:

Private Sub FilterOK_Click()
  Dim tbl As ListObject
  Dim col As ListColumn
  Dim fnd As Range
 
  Set tbl = ActiveSheet.ListObjects("ItemsImport")
  Set col = tbl.ListColumns("Afwijking %" & Chr(10) & "Opslag")
  Set fnd = col.Range.Find("ok", , xlValues, xlWhole, , , False)
 
  Application.ScreenUpdating = False
  If Not fnd Is Nothing Then
    tbl.Range.AutoFilter col.Index, "ok"
    tbl.DataBodyRange.EntireRow.Delete
    ActiveSheet.ShowAllData
  End If
  Application.ScreenUpdating = True
End Sub

Good afternoon., unfortunately I get another error now, subscript out of range. I can't find it,but I added the sheet for small part so maybe that helps.

Artikelen beheren 6.03.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG	AH	AI	AJ	AK	AL	AM	AN	AO	AP	AQ	AR	AS	AT	AU	AV	AW	AX	AY	AZ	BA	BB	BC	BD	BE	BF	BG	BH	BI	BJ	BK	BL	BM	BN	BO	BP	BQ	BR	BS	BT	BU	BV	BW	BX	BY	BZ	CA	CB	CC	CD	CE	CF	CG	CH	CI	CJ	CK	CL	CM	CN	CO
1	Importdatum	11/01/2024	C:\TEMP\ART051_2024-01-11.XML			VERKOOP							KOSTPRIJS																								LEVERANCIER				INKOOP				VOORRAAD/INKOOP																VRIJE VELDEN
2	Resource	1005														Opslag
3	Valuta	EUR														3%
4	Teller	51																	Prijslijst filter A	Prijslijst filter B	Prijslijst filter C	Prijslijst filter D	Verpakkingseenheid	Kleur	Specifiek	Vawa voorraad	Kostprijs factor	Omverpakking																																EAN Verkoopeenheid	EAN Omverpakking	Maatvoering schapkaart
5	Artikelcode	Zoekcode	Omschrijving	Status	Startdatum	Verkoopprijs	Verkoopprijs nieuw	Vkp bedrag	Vkp + opslag	Kp +opslag	Kp +marge	Eenheid	Kostprijs	Kostprijs nieuw	Ikp +opslag%	Afwijking% opslag	Inkoopprijs	BTW_V	Assortiment01	Assortiment02	Assortiment03	Assortiment04	Assortiment05	Assortiment06	Assortiment07	Assortiment08	Assortiment09	Assortiment10	TekstArt	Deelbaar	Verkoop	Korting	Explod	Inkoop	Batch	Serienr	Crdnr	CrdNaam	HoofdLev	ArtLev	Inkoopprijs	Inkoopprijs nieuw	Ikp bedrag	Ikp% opslag	Valuta_I	Inkoopeenheid	BTW_I	InkFactor	Bstgr	Levertijd	Voorraad	Bestel_beleid	Bestelniveau	Max_voorraad	Netto_gewicht	Telfreq	Artgroep	Magazijn	Locatie	GTIN_Lev	UserField_01	UserField_02	UserField_03	UserField_04	UserField_05	UserField_06	UserField_07	UserField_08	UserField_09	UserField_10	UserNumber_01	UserNumber_02	UserNumber_03	UserNumber_04	UserNumber_05	UserNumber_06	UserNumber_07	UserNumber_08	UserNumber_09	UserNumber_10	UserNumber_11	UserNumber_12	UserNumber_13	UserDate_01	UserDate_02	UserDate_03	UserDate_04	UserDate_05	UserYesNo_01	UserYesNo_02	UserYesNo_03	UserYesNo_04	UserYesNo_05
6	100000	8712759037825	Vito Glaserfix 111 6x2 mm wit - 10x25 m	A	24/09/2019	2,00						pak	5,00			-26,08%	6,50	1	CELBANDPE	VITO	GLASERFIX			WIT	--	1	3	16	0	0	1	0	0	1	0	0	10027	Vito GmbH	1	0590250060200128	6,50				EUR	pack	ICV	1	96	21	1	F	19	115	0	0	1	1	P02B	8712759037825	8712759037825	4044041014158	6x2								0	0	0	0		0	0	0	0	0	0	0	0					05/10/2023	1	1	0	0	0
7	100001	8712759037832	Vito Glaserfix 111 6x2 mm zwart - 10x25 m	A	24/09/2019	4,00						pak	6,00			-10,69%	6,50	1	CELBANDPE	VITO	GLASERFIX			ZWART	--	11	3	16	0	1	1	0	0	1	0	0	10027	Vito GmbH	1	0590250060200120	6,50				EUR	pack	ICV	1	96	21	1	F	12	108	0	0	1	1	P04B	8712759037832	8712759037832	4044041014165	6x2								0	0	0	0		0	0	0	0	0	0	0	0					09/10/2023	1	1	0	0	0
8	100002	8712759037849	Vito Glaserfix 111 6x3 mm wit - 10x25 m	A	24/09/2019	5,00						pak	7,00			-4,41%	7,10	1	CELBANDPE	VITO	GLASERFIX			WIT	--	30	3	16	0	0	1	0	0	1	0	0	10027	Vito GmbH	1	100250060300528	7,10				EUR	pack	ICV	1	96	21	1	F	30	126	0	0	1	1	P02B	8712759037849	8712759037849	4044041014172	6x3								0	0	0	0		0	0	0	0	0	0	0	0						1	1	0	0	0
9	100003	8712759037856	Vito Glaserfix 111 6x3 mm zwart - 10x25 m	A	24/09/2019	9,00						pak	8,00			9,68%	7,10	1	CELBANDPE	VITO	GLASERFIX			ZWART	--		3	16	0	1	1	0	0	1	0	0	10027	Vito GmbH	1	100250060300520	7,10				EUR	pack	ICV	1	96	21	1	F	7	103	0	0	1	1	P04B	8712759037856	8712759037856	4044041014189	6x3								0	0	0	0		0	0	0	0	0	0	0	0						1	1	0	0	0
10	100004	8712759037863	Vito Glaserfix 111 6x4 mm wit - 10x25 m	A	24/09/2019	10,00						pak	9,00			-9,25%	9,60	1	CELBANDPE	VITO	GLASERFIX			WIT	--	29	3	16	0	1	1	0	0	1	0	0	10027	Vito GmbH	1	0590250060400128	9,60				EUR	pack	ICV	1	96	21	0	L	0	0	0	0	1	1	P02B	8712759037863	8712759037863	4044041014196	6x4								0	0	0	0		0	0	0	0	0	0	0	0					17/08/2023	1	1	0	0	0
Items

Cell Formulas
Range	Formula
B1	B1	=TODAY()
C1	C1	=TEXT("C:\TEMP\ART",0)&TEXT($B$4,"000")&"_"&TEXT($B$1,"JJJJ")&"-"&TEXT($B$1,"MM")&"-"&TEXT($B$1,"DD")&".XML"
P6:P10	P6	=IFERROR(IFS(ROUND((((Q6*$P$3)+Q6)-M6),2)=0,"ok",Q6<>0,(100%-((M6/Q6)))*-100%-$P$3),"")
Q6:Q10	Q6	=IFERROR([@Inkoopprijs]/[@InkFactor],"")
G6:G10	G6	=IFERROR(IFS(K6>0,M6/(1-K6),J6>0,M6*(1*J6)+M6,I6>0,F6*(1*I6)+F6,H6>0,H6),"")
N6:N10	N6	=IFERROR(IFS(O6>0,AO6*(1*O6)+AO6)/AV6,"")
AP6:AP10	AP6	=IFERROR(IFS(AQ6>0,AQ6,AR6>0,AO6*(1*AR6)+AO6),"")

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
F6:F10228,M6:M10228,AO6:AO10228	Expression	=G6	text	NO
P6:P10228	Cell Value	="ok"	text	NO
P6:P10228	Cell Value	contains "inkoopprijs"	text	NO
C6:C10228	Expression	=LEN(C6)>60	text	NO
AY6:AZ10228	Expression	=AND($AY6=1;$AZ6="L")	text	NO
BI6:BJ10228	Cell Value	duplicates	text	NO
BH6:BH10228	Cell Value	duplicates	text	NO
B6:B10228	Cell Value	duplicates	text	NO

Cells with Data Validation
Cell	Allow	Criteria
AA1:AA2	Whole number	between 0 and 1
AA3	Text length	between 0 and 13

 

[DanteAmor]

Now I get script out of range.

In which line do you have the error?


Then check the table name: "ItemsImport" and the column name "Afwijking %" & Chr(10) & "Opslag"

In your original code:

Now on the sheet you put you no longer have the space:

Then, try this:

Private Sub FilterOK_Click()
  Dim tbl As ListObject
  Dim col As ListColumn
  Dim fnd As Range
  
  Set tbl = ActiveSheet.ListObjects("ItemsImport")
  Set col = tbl.ListColumns("Afwijking%" & Chr(10) & "Opslag")
  Set fnd = col.Range.Find("ok", , xlValues, xlWhole, , , False)
  
  Application.ScreenUpdating = False
  If Not fnd Is Nothing Then
    tbl.Range.AutoFilter col.Index, "ok"
    tbl.DataBodyRange.EntireRow.Delete
    ActiveSheet.ShowAllData
  End If
  Application.ScreenUpdating = True
End Sub

 

[Romano_odK]

In which line do you have the error?


Then check the table name: "ItemsImport" and the column name "Afwijking %" & Chr(10) & "Opslag"

In your original code:

View attachment 104796

Now on the sheet you put you no longer have the space:
View attachment 104797


Then, try this:

Private Sub FilterOK_Click()
  Dim tbl As ListObject
  Dim col As ListColumn
  Dim fnd As Range
 
  Set tbl = ActiveSheet.ListObjects("ItemsImport")
  Set col = tbl.ListColumns("Afwijking%" & Chr(10) & "Opslag")
  Set fnd = col.Range.Find("ok", , xlValues, xlWhole, , , False)
 
  Application.ScreenUpdating = False
  If Not fnd Is Nothing Then
    tbl.Range.AutoFilter col.Index, "ok"
    tbl.DataBodyRange.EntireRow.Delete
    ActiveSheet.ShowAllData
  End If
  Application.ScreenUpdating = True
End Sub

Oh wow, that was it, just a space. Ok I am not that good (yet) in VBA but try to learn from every piece I get in front of me. Thank you for your help, it works.

Have a nice evening.

Romano