3 vlookups in VBA - vba

I recently joined, and am looking forward to working with the community!
This is my first VBA project ever. I have a project building a macro, and it requires using several vlookup formulas. The formula looks on subsequent tabs for a translation. So, for values on tab 1 column 1, it looks on tab 2; for tab 1 column 2, it looks on tab 3 and so on.
The problem is that the lookup seems to be functioning more as a "find/replace" instead of a true lookup for exact matches only. Below, is what my research has gotten me to so far. I know there is much to learn - please help!
Thanks!
'Insert Crosswalk columns
Columns("H:H").Insert
Set Rng = Range("H2:H" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_1!C[-7]:C[-6],2,0)"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_1"
Columns("J:J").Insert
Set Rng = Range("J2:J" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_2!C[-9]:C[-8],2,0)"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_2"
Columns("K:K").Insert
Set Rng = Range("K2:K" & Range("A:A").End(xlDown).Row)
'Rng.FormulaR1C1 = "=VLOOKUP(RC[1],Crosswalk_3!C[-10]:C[-9],2,0)"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_3"
Here is the FULL macro - I assume the issue is with the lookups, but I may well be wrong!
Sub MainMacro()
If MsgBox("Before starting, ensure Entity ID is ascending", vbYesNo, "Input Required") = vbYes Then
MsgBox "Please do not use Excel while this macro is running."
Dim Rng As Range
'Insert "Formula" columns
Columns("C:C").Insert
Set Rng = Range("C2:C" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,0)"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Formula1"
Columns("D:D").Insert
Set Rng = Range("D2:D" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],1,0)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Formula2"
Columns("E:E").Insert
Set Rng = Range("E2:E" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Concatenate1"
'Insert Crosswalk columns
Columns("H:H").Insert
Set Rng = Range("H2:H" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_1!C[-7]:C[-6],2,0)"
Range("H1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_1"
Columns("J:J").Insert
Set Rng = Range("J2:J" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[-1],Crosswalk_2!C[-9]:C[-8],2,0)"
Range("J1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_2"
Columns("K:K").Insert
Set Rng = Range("K2:K" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=VLOOKUP(RC[1],Crosswalk_3!C[-10]:C[-9],2,0)"
Range("K1").Select
ActiveCell.FormulaR1C1 = "Crosswalk_3"
'Copy&Paste Values
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
'Clean-up & Final Formatting
Range("G1").Select
Range("G1").Cut Destination:=Range("H1")
Range("I1").Select
Range("I1").Cut Destination:=Range("J1")
Range("L1").Select
Range("L1").Cut Destination:=Range("K1")
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("J:J").Select
Selection.Delete Shift:=xlToLeft
Columns("G:I").Select
Selection.Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Application.CutCopyMode = False
'Apply Filter to isolate duplicates
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
ActiveSheet.Range("$A:$I").AutoFilter Field:=5, Criteria1:=Array( _
"01", "10", "11"), Operator:=xlFilterValues
'Delete dupes
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveSheet.Range("$A:$L").RemoveDuplicates Columns:=Array(1, 2, 6, 7, 8, 9), Header:=xlYes
'Final De-Dupe Process
Columns("C:E").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Columns("C:C").Insert
Set Rng = Range("C2:C" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-1]=R[1]C[-1],1,0)"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Formula1"
Columns("D:D").Insert
Set Rng = Range("D2:D" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=IF(RC[-2]=R[-1]C[-2],1,0)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Formula2"
Columns("E:E").Insert
Set Rng = Range("E2:E" & Range("A:A").End(xlDown).Row)
Rng.FormulaR1C1 = "=CONCATENATE(RC[-2],RC[-1])"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Duplicate Status"
'Copy&Paste Values
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Range("C1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColor = 12632256
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Replace "01", "10", "11" with "Duplicate"
Columns("C:C").Select
Selection.Replace What:="10", Replacement:="Duplicate", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="01", Replacement:="Duplicate", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="11", Replacement:="Duplicate", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Clear filter
Range("C1").Select
ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort.SortFields.Add Key _
:=Range("C1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Inputdata (3)").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Final message for user (manually check for remaining duplicates)
Range("A1").Select
MsgBox "Macro Complete! Remaining duplicates require manual editing."
End If
End Sub

Related

No errors, but Macro works using F8 line by line, not when executing the full macro - excel, vba

I have 6 identical macros in one workbook. 4 out of 6 work good, but I have the same issue for the rest.
If I run the macro from debug window with F8, I have perfect , expected results. If I run a macro normally, I have not any errors, but the result is obviously wrong.
I can guess that at that case , that the macto ignores this part (all mistakes start here), but not sure
ActiveSheet.Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
ActiveSheet.Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastrow)
ActiveSheet.Range("H2:H" & lastrow).Select
The goal of the macro is to filter one tab, put a few columns in another tab; compare values from one of the columns to another tab, remove duplicates , filter and paste the results in the "Results" tab.
When I do this manually I have got 6 rows in a "Result" tab. When I run it normally, I have one row, or nothing..
Can you please kindly advise - what is wrong with this macro?
I have tried to put this line in my code (no luck) :
Application.PrintCommunication = True
I have tried to put DoEvents
ThisWorkbook before each Row, Column and Range - no luck
Many thanks in advance!!
And here is my full code:
Public lastrow As Long
Public FileName As String
Public TabName As String
Sub APP_filtering_new()
'
' APP_filtering Macro
lastrow = ActiveSheet.Range("A1048576").End(xlUp).Row
Sheets("APP-input").Select
ActiveSheet.Rows("1:1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AG$14878").AutoFilter Field:=2, Criteria1:=Array( _
"BRAMPTON", "VANCOUVER, CD", "VANCOUVER", _
"VANCOUVER TERMINAL"), Operator:=xlFilterValues
ActiveSheet.Columns("E:E").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("APP_output").Select
ActiveSheet.Columns("A:A").Select
ActiveSheet.Paste
Sheets("APP-input").Select
ActiveSheet.Columns("N:N").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("APP_output").Select
ActiveSheet.Columns("D:D").Select
ActiveSheet.Paste
Sheets("APP-input").Select
ActiveSheet.Columns("G:G").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("APP_output").Select
ActiveSheet.Columns("E:E").Select
ActiveSheet.Paste
ActiveSheet.Range("F2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = " "
ActiveSheet.Range("F2").Select
Selection.AutoFill Destination:=Range("F2:F" & lastrow)
ActiveSheet.Range("F2:F" & lastrow).Select
ActiveSheet.Range("G2").Select
ActiveCell.FormulaR1C1 = " "
ActiveSheet.Range("G2").Select
Selection.AutoFill Destination:=Range("G2:G" & lastrow)
ActiveSheet.Range("G2:G" & lastrow).Select
ActiveSheet.Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
ActiveSheet.Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastrow)
ActiveSheet.Range("H2:H" & lastrow).Select
ActiveSheet.Columns("H:H").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'remove duplicates
ActiveSheet.Columns("A:H").Select
Application.CutCopyMode = False
ActiveSheet.Range("A1:E" & lastrow).RemoveDuplicates Columns:=5, Header:= _
xlNo
'vlookup, IF condition
ActiveSheet.Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-4],container,4,FALSE)"
ActiveSheet.Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I" & lastrow)
ActiveSheet.Range("I2:I" & lastrow).Select
ActiveSheet.Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC[-1]<RC[-2],""C. has bigger number of Containers"",IF(RC[-1]=RC[-2],""The same amount of containers"",IF(RC[-2]<RC[-1],""The C. has less amount of Containers"")))"
ActiveSheet.Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J" & lastrow)
ActiveSheet.Range("J2:J" & lastrow).Select
ActiveSheet.Range("H1").Select
ActiveCell.FormulaR1C1 = "Amt of Containers - External report"
ActiveSheet.Range("I1").Select
ActiveCell.FormulaR1C1 = "Amt of Containers - Internal report"
ActiveSheet.Range("J1").Select
ActiveCell.FormulaR1C1 = "Result (N/A means New Shipment)"
ActiveSheet.Range("H1:J1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveSheet.Range("H1:I1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("J1").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("J1").Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("D1:J" & lastrow).AutoFilter Field:=7, Criteria1:=Array( _
"#N/A", "C. has bigger number of Containers", _
"The C. has less amount of Containers"), Operator:=xlFilterValues
' paste in next empty row
ActiveSheet.Rows("2:2").Select
ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Results").Select
lastrow = ActiveSheet.Range("A1048576").End(xlUp).Row
ActiveSheet.Range("A" & lastrow + 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
This isn't a full answer, but e.g this block of code
ActiveSheet.Range("H2").Select
ActiveCell.FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
ActiveSheet.Range("H2").Select
Selection.AutoFill Destination:=Range("H2:H" & lastrow)
ActiveSheet.Range("H2:H" & lastrow).Select
can be replaced by a single line
ActiveSheet.Range("H2:H" & lastrow).FormulaR1C1 = "=COUNTIF(C[-3],RC[-3])"
Get rid of ActiveSheet and replace with the actual sheet name.

How to Merge Name (guest) who has the same Room Number but A different Status

Here is my situation..
I have this file :
1004 Dr Margarita Solorzano Olabarria SILVER 228230185
1004 Mr Jose Manuel Santos Aboim Inglez BRONZE 236338858
1007 Mrs Amanda De Souza Rodrigues BRONZE 238246729
1007 Mr Eduardo Jaime Smejoff BRONZE 214046768
1010 Mrs Genevieve Thie PLATIN 221093078
1010 Mrs Mary Wilson PLPLUS 21384102
1203 Ms Valerie Harrison BRONZE 207754414
1203 Ms Joy Bridget Moncrieff BRONZE 207754415
with In Column A : Cabin Number
Column B: Mr or Mrs
Column C: First & Last Name
Column D: Status (bronze, silver etc...)
Column E: Membership number
If Column A are the same I want it on the same row. but it Excludes Status Bronze, Silver,Gold,
So I put this in my VBA to exclude those :
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")"
When I run the macros it gaves me this :
1211 Mr Thomas Buettner PLPLUS Mr Heinz Juergen Nolte PLPLUS
4011 Mr Michael Brent PLATIN Mrs Wilhelmina Johanna PLATIN
4013 Mrs Nancy Jean PLATIN Mr James PLATIN
4034 Mr Donald Meyer PLATIN Mrs Marcia Meyer PLATIN
1010 Mrs Genevieve Thie PLATIN
1010 Mrs Mary Wilson PLPLUS
Column B: Cabin number
Column C: Mr/Mme + Name of guest 1
Column D:Status (Platin, PLPLUS etc..)
Column E : Mr/Mme + Name of Guest 2
Column F: Status
Look at the Number 1010..
Somehow Both are in the condition but because they have different status, the macro put them in a different row and I don't want that, I want them in the same row..
I want this :
1211 Mr Thomas Buettner PLPLUS Mr Heinz Juergen Nolte PLPLUS
4011 Mr Michael Brent PLATIN Mrs Wilhelmina Johanna PLATIN
4013 Mrs Nancy Jean PLATIN Mr James PLATIN
4034 Mr Donald Meyer PLATIN Mrs Marcia Meyer PLATIN
1010 Mrs Genevieve Thie PLATIN Mrs Mary Wilson PLPLUS
Here is my Code for this sheets called "ChocoStrawb".
' Chocolate
Application.CutCopyMode = False
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "ChocoStrawb"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("ChocoStrawb").Select
Rows("2:4200").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range( _
"A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range( _
"B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("ChocoStrawb").Sort
.SetRange Range("A2:O4200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").Select
Here is my whole Code :
Sub LATDownloadMACROS()
'
' LATDownloadMACROS Macro
' Macro recorded 02/25/2017 by Johan Esteve
' Debut Macro
Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
Cells.EntireColumn.AutoFit
Columns("D:D").Insert Shift:=xlToRight
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns("E:E").Insert Shift:=xlToRight
Range("E2").FormulaR1C1 = "=PROPER(RC[-3])&"" ""&PROPER(RC[-1])&"" ""&PROPER(RC[-2])"
Range("E2").AutoFill Destination:=Range("E2:E4200"), Type:=xlFillDefault
Range("E2:E4200").Select
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Columns("B:D").Select
Range("D1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B18").Select
Sheets("Sheet1").Select
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Download"
Sheets("Download").Select
Cells.Select
Selection.Copy
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Guest 1"
Range("C1").FormulaR1C1 = "Level1"
Range("D1").FormulaR1C1 = "Guest 2"
Range("E1").FormulaR1C1 = "Level2"
Range("F1").FormulaR1C1 = "Guest 3"
Range("G1").FormulaR1C1 = "Level3"
Range("F1:G1").AutoFill Destination:=Range("F1:M1"), Type:=xlFillDefault
Range("D1").FormulaR1C1 = "Guest 2"
Range("D2").FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],RC[-2],"""")"
Range("E2").FormulaR1C1 = "=IF(RC[-4]=R[-1]C[-4],RC[-2],"""")"
Range("D2").FormulaR1C1 = "=IF(R[1]C[-3]=RC[-3],R[1]C[-2],"""")"
Range("E2").FormulaR1C1 = "=IF(R[1]C[-4]=RC[-4],R[1]C[-2],"""")"
Range("F2").FormulaR1C1 = "=IF(R[2]C[-5]=RC[-5],R[2]C[-4],"""")"
Range("G2").FormulaR1C1 = "=IF(R[2]C[-6]=RC[-6],R[2]C[-4],"""")"
Range("H2").FormulaR1C1 = "=IF(R[3]C[-7]=RC[-7],R[3]C[-6],"""")"
Range("I2").FormulaR1C1 = "=IF(R[3]C[-8]=RC[-8],R[3]C[-6],"""")"
Range("J2").FormulaR1C1 = "=IF(R[4]C[-9]=RC[-9],R[4]C[-8],"""")"
Range("K2").FormulaR1C1 = "=IF(R[4]C[-10]=RC[-10],R[4]C[-8],"""")"
Range("L2").FormulaR1C1 = "=IF(R[5]C[-11]=RC[-11],R[5]C[-10],"""")"
Range("M2").FormulaR1C1 = "=IF(R[5]C[-12]=RC[-12],R[5]C[-10],"""")"
Range("D2:M2").AutoFill Destination:=Range("D2:M4200"), Type:=xlFillDefault
Range("D2:M4200").Select
Columns("D:M").AutoFit
Sheets("Sheet2").Move Before:=Sheets(1)
Sheets("Sheet2").Select
Sheets("Sheet2").Copy Before:=Sheets(2)
Sheets("Sheet2 (2)").Select
Range("D2").Select
Sheets("Sheet2").Select
Columns("D:M").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Range("A2").FormulaR1C1 = "=IF(RC[1]=R[-1]C[1],""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault
Range("A2:A6").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Sheets("Sheet2 (2)").Select
Columns("A:C").Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A2").FormulaR1C1 = "=if"
Range("A2").FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""BRONZE"",RC[3]=""SILVER""),""Delete"","""")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Columns("A:A").Select
Sheets("Sheet2 (2)").Select
Sheets.Add
Sheets("Sheet4").Select
Sheets("Sheet4").Move After:=Sheets(3)
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Champagne"
Sheets("Sheet2 (2)").Select
Sheets("Sheet2 (2)").Name = "Water"
Columns("E:N").Copy
Sheets("Sheet4").Select
Range("D1").Select
ActiveSheet.Paste
Range("D2").Select
Sheets("Water").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Sheets("Download").Select
Selection.Copy
Columns("A:C").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Columns("A:C").Select
ActiveSheet.Paste
' Ambassador
Application.CutCopyMode = False
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4").Select
Sheets("Sheet4").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4").Select
Sheets("Sheet4").Name = "Ambassador"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLATIN"",RC[3]=""PLPLUS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Ambassador").Select
Rows("2:4200").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Add Key:=Range( _
"A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Add Key:=Range( _
"B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Ambassador").Sort
.SetRange Range("A2:O4200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").Select
' Chocolate
Application.CutCopyMode = False
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "ChocoStrawb"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("ChocoStrawb").Select
Rows("2:4200").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range( _
"A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range( _
"B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("ChocoStrawb").Sort
.SetRange Range("A2:O4200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").Select
' PlatinumPlus
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "PlatPlus"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLATIN"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Platinum
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "Platinum"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Gold
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("E2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers
Range("C6").Select
Range("C496:C4288").Select
Range("C4288:C16").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(5)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Name = "Gold"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""PLATIN"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
' Rajout
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Silver
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Range("C13").Select
Sheets("Platinum").Select
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Range("C7").Select
Sheets("Gold").Select
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "Silver"
Sheets("Silver").Select
Sheets("Silver").Copy Before:=Sheets(6)
Sheets("Silver").Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""PLATIN"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
' Bronze
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Sheets("Silver (2)").Select
Columns("B:D").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("A2").FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""PLATIN"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A519"), Type:=xlFillDefault
Range("A2:A519").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
' Nomage C1
Sheets("Champagne").Select
Range("C1").Select
Selection.Copy
Sheets("Ambassador").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("PlatPlus").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("ChocoStrawb").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("Ambassador").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("Platinum").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("Gold").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("Silver").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("Silver (2)").Select
Range("C1").Select
ActiveSheet.Paste
' Nomage Bronze
Sheets("Silver (2)").Select
Sheets("Silver (2)").Name = "Bronze"
Range("A1").Select
Sheets("Champagne").Select
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("A1").Select
' Filtre et Figer
Sheets("Champagne").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Platinum").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("PlatPlus").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Silver").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Bronze").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Gold").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("ChocoStrawb").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Water").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Ambassador").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Download").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
' Color
Sheets("Champagne").Select
ActiveWorkbook.Sheets("Champagne").Tab.ColorIndex = 6
Sheets("Platinum").Select
ActiveWorkbook.Sheets("Platinum").Tab.ColorIndex = 16
Sheets("PlatPlus").Select
ActiveWorkbook.Sheets("PlatPlus").Tab.ColorIndex = 55
Sheets("Silver").Select
ActiveWorkbook.Sheets("Silver").Tab.ColorIndex = 15
Sheets("Bronze").Select
ActiveWorkbook.Sheets("Bronze").Tab.ColorIndex = 9
Sheets("Gold").Select
ActiveWorkbook.Sheets("Gold").Tab.ColorIndex = 43
Sheets("ChocoStrawb").Select
ActiveWorkbook.Sheets("ChocoStrawb").Tab.ColorIndex = 3
Sheets("Water").Select
ActiveWorkbook.Sheets("Water").Tab.ColorIndex = 2
Sheets("Ambassador").Select
ActiveWorkbook.Sheets("Ambassador").Tab.ColorIndex = 1
Sheets("Download").Select
ActiveWorkbook.Sheets("Download").Tab.ColorIndex = 4
' Delete
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
For x = 4200 To 2 Step -1
If WS.Cells(x, 1).Value = "Delete" Then
WS.Rows(x).EntireRow.Delete
End If
Next x
Next WS
' Formulas
Sheets("Water").Select
Cells.Select
Range("A2").Select
ActiveCell.Formula = "=SUM(D2:N2)+((COUNTIF(D2:N2,""GOLD"")+COUNTIF(D2:N2,""PLATIN""))*1)+((COUNTIF(D2:N2,""PLPLUS"")+COUNTIF(D2:N2,""AMBASS""))*2)"
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("A2").End(xlDown).Row
Cells(LastRow + 2, "A").Formula = "=SUM(A2:A" & LastRow & ")"
Dim LRowA As String, LRowB As String
LRowA = [A4200].End(xlUp).Address
Range("A:A").Interior.ColorIndex = xlNone
Range("A2:" & LRowA).Interior.ColorIndex = 33
Range("A:A").HorizontalAlignment = xlCenter
Sheets("Champagne").Select
Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("B2").End(xlDown).Row
Cells(LastRow + 2, "B").Formula = "=SUM(B2:B" & LastRow & ")"
LRowA = [B4200].End(xlUp).Address
Range("B:B").Interior.ColorIndex = xlNone
Range("B2:" & LRowA).Interior.ColorIndex = 33
Range("B:B").HorizontalAlignment = xlCenter
Sheets("ChocoStrawb").Select
Range("B2").AutoFill Destination:=Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("B2").End(xlDown).Row
Cells(LastRow + 2, "B").Formula = "=SUM(B2:B" & LastRow & ")"
LRowA = [B4200].End(xlUp).Address
Range("B:B").Interior.ColorIndex = xlNone
Range("B2:" & LRowA).Interior.ColorIndex = 33
Range("B:B").HorizontalAlignment = xlCenter
' Classement Onglets
Sheets("Water").Select
Sheets("Water").Move Before:=Sheets(2)
Sheets("ChocoStrawb").Select
Sheets("ChocoStrawb").Move Before:=Sheets(3)
Sheets("Bronze").Select
Sheets("Bronze").Move Before:=Sheets(4)
Sheets("Silver").Select
Sheets("Silver").Move Before:=Sheets(5)
Sheets("Gold").Select
Sheets("Gold").Move Before:=Sheets(6)
Sheets("Champagne").Select
End Sub
Consider an SQL solution using the Windows Jet/ACE SQL engine. Two things though are required: 1) use Excel for Windows and 2) add column names as top header of data. Below assumes data resides in a tab named DATA and an existing tab named RESULTS to hold SQL results. Two connection types are included.
Public Sub RunSQL()
Dim conn As Object, rst As Object
Dim strConnection As String, strSQL As String
Dim i As Integer
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
' DRIVER AND PROVIDER CONNECTION TYPES
' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _
' & "DBQ=C:\Path\To\Workbook.xlsm;"
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "Data Source='C:\Path\To\Workbook.xlsm';" _
& "Extended Properties=""Excel 12.0;HDR=YES;"";"
strSQL = " SELECT t1.[CabinNumber], t1.[Mr./Mrs.], t1.[First & Last Name], t1.Status, " _
& " t2.[Mr./Mrs.], t2.[First & Last Name], t2.Status" _
& " FROM [DATA$] t1 INNER JOIN [DATA$A] t2" _
& " ON t1.[CabinNumber] = t2.[CabinNumber]" _
& " WHERE NOT t1.Status IN ('Gold', 'Silver', 'Bronze')"
' OPEN DB CONNECTION
conn.Open strConnection
rst.Open strSQL, conn
' COLUMN HEADERS
For i = 1 To rst.Fields.Count
Worksheets("RESULTS").Cells(1, i) = rst.Fields(i - 1).Name
Next i
' DATA ROWS
Worksheets("RESULTS").Range("A2").CopyFromRecordset rst
' CLOSE OBJECTS AND FREE RESOURCES
rst.Close: conn.Close
Set rst = Nothing: Set conn = Nothing
End Sub
It is difficult to follow exactly (based on your examples) where the breakdown is happening. In the initial example, you show that 1010 has a duplicate, as do others, then in the second example you don't show the same data (only 1010 shows up as a duplicate). I would have expected 1004 duplicates to be moved up to see what's all going on, which is in the first example, but not in the second.
Assuming I follow, I would recommend keeping your sorting, then instead of using a activecell.formula to determine what gets moved where, just use VBA. Loop through and determine what lines are the same, then move the items you need the same; after cut/paste, delete the row.
Dim i as Integer
For i = 3 to 4200 '4200 taken from your range. starting at 3 because range starts at 2 (i-1)
If Cells(i-1,1).Value=Cells(i,1).Value Then
Range(Cells(i,2),Cells(i,4)).Cut Range(Cells(i-1,5),Cells(i-1,7))
Row(i).Delete
End If
Next i
Edit:
You should be able to shorten up your sorting, too:
Sheets("ChocoStrawb").Range("A1:H4200).Sort key1:=Range("A:A"), order1:=xlAscending, Header:=xlYes
Essentially your whole code to sort through your sheet, move people sharing a cabin. then delete empty rows, would look like this:
Dim i as Integer
Sheets("ChocoStrawb").Range("A1:H4200).Sort key1:=Range("A:A"), order1:=xlAscending, Header:=xlYes
For i = 3 to 4200 '4200 taken from your range. starting at 3 because range starts at 2 (i-1)
With Sheets("ChocoStrawb")
If .Cells(i-1,1).Value=.Cells(i,1).Value Then
.Range(Cells(i,2),Cells(i,4)).Cut .Range(Cells(i-1,5),Cells(i-1,7))
.Row(i).Delete
End If
End With
Next i
That should be an overall improvement. Try to avoid select/activate in your coding, as it complicates the steps.

How to align duplicates on the same rows in Excel in VBA

Here is my situation..
I have this file :
1004 Dr Margarita Solorzano Olabarria SILVER 228230185
1004 Mr Jose Manuel Santos Aboim Inglez BRONZE 236338858
1007 Mrs Amanda De Souza Rodrigues BRONZE 238246729
1007 Mr Eduardo Jaime Smejoff BRONZE 214046768
1010 Mrs Genevieve Thie PLATIN 221093078
1010 Mrs Mary Wilson PLPLUS 21384102
1203 Ms Valerie Harrison BRONZE 207754414
1203 Ms Joy Bridget Moncrieff BRONZE 207754415
with In Column A : Cabin Number
Column B: Mr or Mrs
Column C: First & Last Name
Column D: Status (bronze, silver etc...)
Column E: Membership number
If Column A are the same I want it on the same row. but it Excludes Status Bronze, Silver,Gold,
So I put this in my VBA to exclude those :
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")"
When I run the macros it gaves me this :
1211 Mr Thomas Buettner PLPLUS Mr Heinz Juergen Nolte PLPLUS
4011 Mr Michael Brent PLATIN Mrs Wilhelmina Johanna PLATIN
4013 Mrs Nancy Jean PLATIN Mr James PLATIN
4034 Mr Donald Meyer PLATIN Mrs Marcia Meyer PLATIN
1010 Mrs Genevieve Thie PLATIN
1010 Mrs Mary Wilson PLPLUS
Look at the Number 1010..
Somehow Both are in the condition but because they have different status, the macro put them in a different row and I don't want that, I want them in the same row..
Can you help me..
Added on Mar 7th, Here is My whole Macro (I don't want an another Sub) :
Sub LATDownloadMACROS()
'
' LATDownloadMACROS Macro
' Macro recorded 02/25/2017 by Johan Esteve
' Debut Macro
Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
Cells.EntireColumn.AutoFit
Columns("D:D").Insert Shift:=xlToRight
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Columns("E:E").Insert Shift:=xlToRight
Range("E2").FormulaR1C1 = "=PROPER(RC[-3])&"" ""&PROPER(RC[-1])&"" ""&PROPER(RC[-2])"
Range("E2").AutoFill Destination:=Range("E2:E4200"), Type:=xlFillDefault
Range("E2:E4200").Select
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Columns("B:D").Select
Range("D1").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("B18").Select
Sheets("Sheet1").Select
Sheets.Add
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Download"
Sheets("Download").Select
Cells.Select
Selection.Copy
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Range("B1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Guest 1"
Range("C1").FormulaR1C1 = "Level1"
Range("D1").FormulaR1C1 = "Guest 2"
Range("E1").FormulaR1C1 = "Level2"
Range("F1").FormulaR1C1 = "Guest 3"
Range("G1").FormulaR1C1 = "Level3"
Range("F1:G1").AutoFill Destination:=Range("F1:M1"), Type:=xlFillDefault
Range("D1").FormulaR1C1 = "Guest 2"
Range("D2").FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],RC[-2],"""")"
Range("E2").FormulaR1C1 = "=IF(RC[-4]=R[-1]C[-4],RC[-2],"""")"
Range("D2").FormulaR1C1 = "=IF(R[1]C[-3]=RC[-3],R[1]C[-2],"""")"
Range("E2").FormulaR1C1 = "=IF(R[1]C[-4]=RC[-4],R[1]C[-2],"""")"
Range("F2").FormulaR1C1 = "=IF(R[2]C[-5]=RC[-5],R[2]C[-4],"""")"
Range("G2").FormulaR1C1 = "=IF(R[2]C[-6]=RC[-6],R[2]C[-4],"""")"
Range("H2").FormulaR1C1 = "=IF(R[3]C[-7]=RC[-7],R[3]C[-6],"""")"
Range("I2").FormulaR1C1 = "=IF(R[3]C[-8]=RC[-8],R[3]C[-6],"""")"
Range("J2").FormulaR1C1 = "=IF(R[4]C[-9]=RC[-9],R[4]C[-8],"""")"
Range("K2").FormulaR1C1 = "=IF(R[4]C[-10]=RC[-10],R[4]C[-8],"""")"
Range("L2").FormulaR1C1 = "=IF(R[5]C[-11]=RC[-11],R[5]C[-10],"""")"
Range("M2").FormulaR1C1 = "=IF(R[5]C[-12]=RC[-12],R[5]C[-10],"""")"
Range("D2:M2").AutoFill Destination:=Range("D2:M4200"), Type:=xlFillDefault
Range("D2:M4200").Select
Columns("D:M").AutoFit
Sheets("Sheet2").Move Before:=Sheets(1)
Sheets("Sheet2").Select
Sheets("Sheet2").Copy Before:=Sheets(2)
Sheets("Sheet2 (2)").Select
Range("D2").Select
Sheets("Sheet2").Select
Columns("D:M").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlToRight
Range("A2").FormulaR1C1 = "=IF(RC[1]=R[-1]C[1],""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault
Range("A2:A6").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Sheets("Sheet2 (2)").Select
Columns("A:C").Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A2").FormulaR1C1 = "=if"
Range("A2").FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""BRONZE"",RC[3]=""SILVER""),""Delete"","""")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Columns("A:A").Select
Sheets("Sheet2 (2)").Select
Sheets.Add
Sheets("Sheet4").Select
Sheets("Sheet4").Move After:=Sheets(3)
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Champagne"
Sheets("Sheet2 (2)").Select
Sheets("Sheet2 (2)").Name = "Water"
Columns("E:N").Copy
Sheets("Sheet4").Select
Range("D1").Select
ActiveSheet.Paste
Range("D2").Select
Sheets("Water").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Sheets("Download").Select
Selection.Copy
Columns("A:C").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet4").Select
Columns("A:C").Select
ActiveSheet.Paste
' Ambassador
Application.CutCopyMode = False
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4").Select
Sheets("Sheet4").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4").Select
Sheets("Sheet4").Name = "Ambassador"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLATIN"",RC[3]=""PLPLUS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Ambassador").Select
Rows("2:4200").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Add Key:=Range( _
"A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Add Key:=Range( _
"B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Ambassador").Sort
.SetRange Range("A2:O4200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").Select
' Chocolate
Application.CutCopyMode = False
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "ChocoStrawb"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("ChocoStrawb").Select
Rows("2:4200").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range( _
"A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range( _
"B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("ChocoStrawb").Sort
.SetRange Range("A2:O4200")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").Select
' PlatinumPlus
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "PlatPlus"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLATIN"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Platinum
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers
Columns("A:A").Insert Shift:=xlToRight
Range("A1").FormulaR1C1 = ""
Range("A2").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(3)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Move After:=Sheets(4)
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "Platinum"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Gold
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("E2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers
Range("C6").Select
Range("C496:C4288").Select
Range("C4288:C16").Select
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Copy Before:=Sheets(5)
Sheets("Sheet4 (2)").Select
Sheets("Sheet4 (2)").Name = "Gold"
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""PLATIN"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
' Rajout
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
' Silver
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Range("C13").Select
Sheets("Platinum").Select
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Range("C7").Select
Sheets("Gold").Select
Sheets("Sheet4 (3)").Select
Sheets("Sheet4 (3)").Name = "Silver"
Sheets("Silver").Select
Sheets("Silver").Copy Before:=Sheets(6)
Sheets("Silver").Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""PLATIN"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
' Bronze
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
Sheets("Silver (2)").Select
Columns("B:D").Select
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Range("A2").FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""PLATIN"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")"
Range("A2").AutoFill Destination:=Range("A2:A519"), Type:=xlFillDefault
Range("A2:A519").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault
Range("A2:A4200").Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Cells.Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers
' Nomage C1
Sheets("Champagne").Select
Range("C1").Select
Selection.Copy
Sheets("Ambassador").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("PlatPlus").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("ChocoStrawb").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("Ambassador").Select
Range("D1").Select
ActiveSheet.Paste
Sheets("Platinum").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("Gold").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("Silver").Select
Range("C1").Select
ActiveSheet.Paste
Sheets("Silver (2)").Select
Range("C1").Select
ActiveSheet.Paste
' Nomage Bronze
Sheets("Silver (2)").Select
Sheets("Silver (2)").Name = "Bronze"
Range("A1").Select
Sheets("Champagne").Select
Range("A1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
Range("A1").Select
' Filtre et Figer
Sheets("Champagne").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Platinum").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("PlatPlus").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Silver").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Bronze").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Gold").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("ChocoStrawb").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Water").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Ambassador").Select
Cells.Select
Cells.EntireColumn.AutoFit
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("C2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
Sheets("Download").Select
Cells.Select
Cells.EntireColumn.AutoFit
Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select
Selection.AutoFilter
' Color
Sheets("Champagne").Select
ActiveWorkbook.Sheets("Champagne").Tab.ColorIndex = 6
Sheets("Platinum").Select
ActiveWorkbook.Sheets("Platinum").Tab.ColorIndex = 16
Sheets("PlatPlus").Select
ActiveWorkbook.Sheets("PlatPlus").Tab.ColorIndex = 55
Sheets("Silver").Select
ActiveWorkbook.Sheets("Silver").Tab.ColorIndex = 15
Sheets("Bronze").Select
ActiveWorkbook.Sheets("Bronze").Tab.ColorIndex = 9
Sheets("Gold").Select
ActiveWorkbook.Sheets("Gold").Tab.ColorIndex = 43
Sheets("ChocoStrawb").Select
ActiveWorkbook.Sheets("ChocoStrawb").Tab.ColorIndex = 3
Sheets("Water").Select
ActiveWorkbook.Sheets("Water").Tab.ColorIndex = 2
Sheets("Ambassador").Select
ActiveWorkbook.Sheets("Ambassador").Tab.ColorIndex = 1
Sheets("Download").Select
ActiveWorkbook.Sheets("Download").Tab.ColorIndex = 4
' Delete
Dim WS As Worksheet
For Each WS In ActiveWorkbook.Worksheets
For x = 4200 To 2 Step -1
If WS.Cells(x, 1).Value = "Delete" Then
WS.Rows(x).EntireRow.Delete
End If
Next x
Next WS
' Formulas
Sheets("Water").Select
Cells.Select
Range("A2").Select
ActiveCell.Formula = "=SUM(D2:N2)+((COUNTIF(D2:N2,""GOLD"")+COUNTIF(D2:N2,""PLATIN""))*1)+((COUNTIF(D2:N2,""PLPLUS"")+COUNTIF(D2:N2,""AMBASS""))*2)"
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row)
LastRow = Range("A2").End(xlDown).Row
Cells(LastRow + 2, "A").Formula = "=SUM(A2:A" & LastRow & ")"
Dim LRowA As String, LRowB As String
LRowA = [A4200].End(xlUp).Address
Range("A:A").Interior.ColorIndex = xlNone
Range("A2:" & LRowA).Interior.ColorIndex = 33
Range("A:A").HorizontalAlignment = xlCenter
' Classement Onglets
Sheets("Water").Select
Sheets("Water").Move Before:=Sheets(2)
Sheets("ChocoStrawb").Select
Sheets("ChocoStrawb").Move Before:=Sheets(3)
Sheets("Bronze").Select
Sheets("Bronze").Move Before:=Sheets(4)
Sheets("Silver").Select
Sheets("Silver").Move Before:=Sheets(5)
Sheets("Gold").Select
Sheets("Gold").Move Before:=Sheets(6)
Sheets("Champagne").Select
End Sub
This My Whole Code.. Now Under 'Chocolate sheets and 'water sheets I want the same cabin on the same row if they are valid for the condition even do they are different status.
assuming your data are:
in worksheet named after "mySheetName"
in columns from A to D
with first row as a "header" one
with all records sharing the same "code" in a contiguous range
then you could use:
Option Explicit
Sub main()
Dim code As Variant
With Sheets("mySheetName") '<--| change "mySheetName" to your actual sheet name
With .Range("D1", .cells(.Rows.Count, "A").End(xlUp)) '<--| reference its columns A:D range from row 1 (header) down to the one corresponding to last column A not empty row
DeleteSilverAndBronzeRecords .cells '<--| delete all records with "SILVER" or "BRONZE" in columnn "C"
For Each code In GetCodes(.Resize(.Rows.Count - 1, 1).Offset(1)) '<-- loop through unique "codes" starting from 2nd row downwards
If Application.WorksheetFunction.CountIf(.cells, code) > 1 Then HandleCodes .cells, code '<--| if more then one current 'code' occurrences then "handle" it
Next
End With
End With
End Sub
Sub DeleteSilverAndBronzeRecords(rng As Range)
With rng
.AutoFilter Field:=3, Criteria1:=Array("GOLD", "SILVER", "BRONZE"), Operator:=xlFilterValues '<--| filter column C cells with "GOLD", "SILVER" or "BRONZE"
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filtered cell other than headers
Application.DisplayAlerts = False
.Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible).Delete '<-- delete filtered cells, skipping headers
Application.DisplayAlerts = True
End If
.Parent.AutoFilterMode = False
End With
End Sub
Sub HandleCodes(rng As Range, code As Variant)
Dim cell As Range
Dim iCell As Long, refvalue As Long
Dim strng As String
With rng
.AutoFilter Field:=1, Criteria1:=code '<--| filter column A cells with current 'code'
If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then
With .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible) '<-- reference filtered cells, skipping headers
For Each cell In .cells '<--| loop through filtered cells
strng = strng & Join(Application.Transpose(Application.Transpose(cell.Offset(, 1).Resize(, 2).Value)), " ") & " " '<--| build concatenated string from all current 'code' records
Next
.cells(1, 2).Value = WorksheetFunction.Trim(strng) '<--| write updated column "B" content in first record with current "code"
Application.DisplayAlerts = False
.Resize(.Rows.Count - 1).Offset(1).Delete '<--| delete all current "code" occurrences from the 2nd one on
Application.DisplayAlerts = True
End With
End If
.Parent.AutoFilterMode = False
End With
End Sub
Function GetCodes(rng As Range) As Variant
Dim cell As Range
With CreateObject("Scripting.Dictionary")
For Each cell In rng
.Item(cell.Value) = cell.Value
Next cell
GetCodes = .keys
End With
End Function
In excel --- Home---Conditional formatting ---highlight cell rules----duplicate values--- (Select your range and do) Let me know in case you need more

Excel VB, find and move row to bottom of list separate with new heading

I am able to get the result that I want to get with my code which is as follows:
Sub Button1_Click()
With Worksheets("Data").Select
With Range("A11:H11").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
With Selection.Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
With Range("E11").Select
ActiveCell.FormulaR1C1 = "Seasonal Items"
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="fan", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
With Worksheets("Data").Select
With Range("B2").Select
Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Copy
Rows("12:12").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
With Range("B2").Select
Cells.Find(What:="Heater", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlAll, MatchCase:=False, SearchFormat:=False).Activate
With Selection
ActiveCell.EntireRow.Select
With Selection
Selection.Delete Shift:=xlUp
End With
End With
End With
End With
End With
End With
End With
End Sub
This code is not very elegant nor is it flowing really.
What I would like it to do is automatically search for specific wording in the column B which is either Fan or Heater, then move it to the bottom, where it is separated with a row that states season items.
See the picture below of the result:
Why I want it different is due to that the stuff is flowing and changing at points... It would make it simpler and I also would like the code to be much shorter and not for me to each time physically having to check and edit the code before running it...
Thank you for taking the time to view this and if possible provide a solution.
Something like this will move the rows the way you want them, but you will need to add in the specific formatting yourself.
Sub test()
Dim lRow As Integer
Dim lrow2 As Integer
Dim i As Integer
lRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row
ActiveSheet.Cells(lRow + 1, 5).Value = "Seasonal Items"
With ThisWorkbook.ActiveSheet
For i = 2 To lRow
lrow2 = ActiveSheet.Cells(ActiveSheet.Rows.Count, 5).End(xlUp).Row + 1
If InStr(.Cells(i, 2), "Fan") > 0 Or InStr(.Cells(i, 2), "Heater") > 0 Then
.Rows(lrow2 & ":" & lrow2).Value = .Rows(i & ":" & i).Value
.Rows(i & ":" & i).ClearContents
End If
Next i
For i = 2 To lrow2
If .Cells(i, 1).Value = "" Then
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With
End Sub

VBA Sort Macro not working

The sort code is not working anymore. It worked the first time. Then I closed it and opened it and then it gave me an error. (I didn't change anything.) It gave me:
Error 438: Object doesn't support this property or method
On this line:
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal`
Snippet of sort code:
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
DataWB.DataSheet.Sort.SortFields.Clear
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DataWB.DataSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Entire Code:
Sub iGetData()
Dim ValidatorWB As Workbook
Dim PopDetail As Worksheet
Dim DataSheetName As String
Dim DataWB As Workbook
Dim DataSheet As Worksheet
Dim Ret
Dim DWBName As String
Dim FNOrder As String
Dim FNOrdCol As String
Set PopDetail = Worksheets("PopulateWireframe")
Set ValidatorWB = Workbooks(ActiveWorkbook.Name)
DataSheetName = Range("F18").Value
FNOrder = Range("F33").Value
Application.ScreenUpdating = False
'Open data file
Ret = IsWorkBookOpen(PopDetail.Range("C18").Value)
If Ret = False Then
Workbooks.Open PopDetail.Range("C18").Value
DataFileName = ActiveWorkbook.Name
Set DataWB = Workbooks(DataFileName)
Set DataSheet = Worksheets(DataSheetName)
Dim FilterColumn As String
Dim FilterCriteria As String
Dim ColumnNumber As Integer
'Set filter
With DataSheet
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
ValidatorWB.Activate
PopDetail.Activate
For x = 21 To 30
If Range("E" & x).Value <> "" And Range("F" & x).Value <> "" Then
FilterColumn = PopDetail.Range("E" & x).Value
FilterCriteria = PopDetail.Range("F" & x).Value
DataWB.Activate
DataSheet.Activate
DataSheet.Range("A1").Select
Selection.End(xlToLeft).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FilterColumn, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ColumnNumber = ActiveCell.Column
DataSheet.AutoFilterMode = False
DataSheet.Range("A1").AutoFilter Field:=ColumnNumber, Criteria1:=FilterCriteria
End If
ValidatorWB.Activate
PopDetail.Activate
'x = x + 1
Next x
DataWB.Activate
DataSheet.Activate
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
DataWB.DataSheet.Sort.SortFields.Clear
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DataWB.DataSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Copy data
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data to validator
ValidatorWB.Activate
ValidatorWB.Sheets.Add().Name = "ValidatorData"
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 15
Application.CutCopyMode = False
'DataWB.Close savechanges:=False
If DataWB.Windows(1).Visible = True Then
DataWB.Windows(1).Visible = False
End If
Application.ScreenUpdating = True
PopDetail.Activate
Else
DWBName = GetFilenameFromPath(PopDetail.Range("C18").Value)
Set DataWB = Workbooks(DWBName)
DataWB.Activate
Set DataSheet = Worksheets(DataSheetName)
DataSheet.Activate
With DataSheet
If (ActiveSheet.AutoFilterMode And ActiveSheet.FilterMode) Or ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
End With
ValidatorWB.Activate
PopDetail.Activate
For x = 21 To 30
If Range("E" & x).Value <> "" And Range("F" & x).Value <> "" Then
FilterColumn = PopDetail.Range("E" & x).Value
FilterCriteria = PopDetail.Range("F" & x).Value
DataWB.Activate
DataSheet.Activate
DataSheet.Range("A1").Select
Selection.End(xlToLeft).Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FilterColumn, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ColumnNumber = ActiveCell.Column
DataSheet.AutoFilterMode = False
DataSheet.Range("A1").AutoFilter Field:=ColumnNumber, Criteria1:=FilterCriteria
End If
ValidatorWB.Activate
PopDetail.Activate
'x = x + 1
Next x
DataWB.Activate
DataSheet.Activate
'Alpahebtical order
DataSheet.Range("A1").Select
ActiveCell.Rows("1:1").EntireRow.Select
Selection.Find(What:=FNOrder, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
FNOrdCol = ActiveCell.Address
'DataWB.DataSheet.Sort.SortFields.Clear
DataWB.DataSheet.Sort.SortFields.Add Key:=Range(FNOrdCol), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With DataWB.DataSheet.Sort
.SetRange DataSheet.Cells
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Copy data
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
'Paste data to validator
ValidatorWB.Activate
ValidatorWB.Sheets.Add().Name = "ValidatorData"
ActiveCell.Offset(3, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveCell.Columns("A:A").EntireColumn.ColumnWidth = 15
Application.CutCopyMode = False
'DataWB.Close savechanges:=False
If DataWB.Windows(1).Visible = True Then
DataWB.Windows(1).Visible = False
End If
Application.ScreenUpdating = True
PopDetail.Activate
End If
End Sub
If the debugging info shows that the FNOrder variable is correctly assigned, then this shortened version of your sort code should be all that you require.
debug.print FNOrder & " is the name of the column to be sorted on"
With DataSheet
With .Cells(1, 1).CurrentRegion
.Cells.Sort Key1:=.Columns(Application.Match(FNOrder, .Rows(1), 0)), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes
.Cells.Copy
End With
End With
If DataSheet has been properly defined, you do not need to specify the parent workbook.
At the end of that code section, the data should be sorted and 'on-the-clipboard'. You still need to add a new worksheet to the ValidatorWB workbook and paste the values.
If that crashes, check the VBE's Immediate window (e.g. Ctrl+G) to see what was reported as being the value of FNOrder.
If you get this running to your satisfaction, I would recommend posting it in Code Review (Excel) for optimization tips.
Fixed. I changed DataWB.DataSheet in all references to just ActiveSheet. Thank you for the help.