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.
From multiple workbooks I copy info into one Workbook. This works like a charm. I just got informed that in a few weeks I'll have to add another file to copy data from. I wanted to get the Macro going now but if I don't have the new workbook open the macro gets stuck. I have tried a few different ways but I don't get it to work.
I have the same code going with the other 3 workbooks, so when this comes I want the macro to skip it if Workbook is not open.
Any suggestions?
Windows("filename.xlsx").Activate
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy
Workbooks("Masterfile.xlsm").Sheets("Electra").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
This code will step through the workbooks that you have open and check against a list of file names that you need.
There's a couple of problems that could occur:
Your workbook must have a sheet called Sheet1 as the code doesn't check for this.
If you have a file called book1.xlsm and 1book1.xlsm. book1.xlsm occurs in both.
Finding the last cell in columns A:K could be improved. Currently it will go from A2 to the last row containing data in column K.
All information will be pasted starting at cell A2. You need code to find the last row on the Electra sheet as well.
Sub Test()
Dim sFileNames As String
Dim wrkBk As Workbook
sFileNames = "Somebook.xls, book1.xlsm, book2.xlsx"
For Each wrkBk In Workbooks
If InStr(UCase(sFileNames), UCase(wrkBk.Name)) > 0 Then
With wrkBk.Worksheets("Sheet1")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 11).End(xlUp)).Copy
ThisWorkbook.Worksheets("Electra").Range("A2").PasteSpecial xlPasteValues
End With
End If
Next wrkBk
End Sub
Edit:
To paste to different sheets in the MasterFile one option is to use a dictionary to hold workbook & destination sheet pairings.
This code will add the file names as keys and the destination sheets as values. It then checks if the workbook name exists within the dictionary, if it does it copies the data from Sheet1 and pastes the values into relevant sheet.
Sub Test()
Dim dict As Object
Dim wrkBk As Workbook
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
dict.Add "Book2.xlsx", "Sheet1"
dict.Add "Book3.xlsx", "Sheet2"
For Each wrkBk In Workbooks
If dict.exists(wrkBk.Name) Then
With wrkBk.Worksheets("Sheet1")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 11).End(xlUp)).Copy
ThisWorkbook.Worksheets(dict(wrkBk.Name)).Range("A2").PasteSpecial xlPasteValues
End With
End If
Next wrkBk
End Sub
Edit 2:
If the source workbooks are all closed at the start then use this code to open the relevant files, copy the info and close the file again.
Sub Test()
Dim dict As Object
Dim wrkBk As Workbook
Dim vItem As Variant
Dim sPath As String
'All workbooks to open will be in this folder.
'Remember to include the final back-slash (\).
sPath = "C:\Test\"
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
'If files will not all be in the same folder, then
'full file path must be included here and remove
'references to sPath variable in the code.
dict.Add "Book2.xlsx", "Sheet1"
dict.Add "Book3.xlsx", "Sheet2"
For Each vItem In dict
Set wrkBk = Workbooks.Open(sPath & vItem)
With wrkBk.Worksheets("Sheet1")
.Range(.Cells(2, 1), .Cells(.Rows.Count, 11).End(xlUp)).Copy
ThisWorkbook.Worksheets(dict(wrkBk.Name)).Range("A2").PasteSpecial xlPasteValues
End With
wrkBk.Close SaveChanges:=False
Next vItem
End Sub
This is maybee the most good looking but it actually worked, I never done Call before so I just had to try. I can run this multiple time with different books open and it don't bug out or mess things up. As faar as two test are made.
Sub Steg11()
'
' Steg1 Macro
' Macrot flyttar data från CDPPT fil med försäljningsdata,
' från fil med Electras försäljning och fil med produktdata.
' Kopierar formler, rensar försäljning till Lagerhållare
Dim MainWkbk As Workbook
Dim NextWkbk As Workbook
Set MainWkbk = ActiveWorkbook
Set NextWkbk = ActiveWorkbook
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
' Letar in CDPPT, lägger in formler, sorterar bladet.
On Error GoTo 3
Windows("CDPPT.xlsx").Activate
Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Copy
Workbooks("Datamatchningsfil.xlsm").Sheets("CDPPT").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("CDPPT").Select
Range(Range("I2"), Range("I2").End(xlToRight)).Copy
Range("H2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Offset(1, 0).Select
ActiveSheet.Paste
Application.Goto Sheets("CDPPT").Range("A:M")
Selection.Sort Key1:=Range("E1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Tar bort data där telia inte ska betala skatt
Application.Goto Sheets("CDPPT").Range("E1")
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*BRIGHTSTAR*" _
, Operator:=xlAnd
ActiveCell.Offset(1, 0).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*ELECTRA*" _
, Operator:=xlAnd
ActiveWindow.SmallScroll Down:=-6
ActiveCell.Offset(1, 0).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*Ingram*" _
, Operator:=xlAnd
ActiveWindow.SmallScroll Down:=-9
ActiveCell.Offset(1, 0).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
ActiveSheet.Range("$A:$M").AutoFilter Field:=3, Criteria1:="=*brev*" _
, Operator:=xlAnd
ActiveCell.Offset(1, 0).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
ActiveSheet.Range("$A:$M").AutoFilter Field:=3, Criteria1:="=*Konfig*" _
, Operator:=xlAnd
ActiveCell.Offset(1, 0).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
ActiveSheet.Range("$A:$M").AutoFilter Field:=5, Criteria1:="=*(Manuellt
inmatad)*" _
, Operator:=xlAnd
ActiveCell.Offset(1, 0).Activate
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
3
Call Produktdata
End Sub
Sub Produktdata()
'Letar in produktdata
On Error GoTo 4
Windows("Produktdata.xlsx").Activate
If ActiveSheet.AutoFilterMode Then Cells.AutoFilter
Range(Range("A:J"), Range("A:J").End(xlDown)).Copy
Workbooks("Datamatchningsfil.xlsm").Sheets("Produktdata").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
4
Call Electra
End Sub
Sub Electra()
'Letar in data från Lagerhållare
On Error GoTo 5
Windows("Electra sales.xlsx").Activate
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy
Workbooks("Datamatchningsfil.xlsm").Sheets("Electra").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
5
Call TalkTelecom
End Sub
Sub TalkTelecom()
'Letar in data från Lagerhållare
On Error GoTo 6
Windows("TalkTelecom.xlsx").Activate
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy
Workbooks("Datamatchningsfil.xlsm").Sheets("TalkTelecom").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
6
Call Techdata
End Sub
Sub Techdata()
'Letar in data från Lagerhållare
On Error GoTo 7
Windows("TechData.xlsx").Activate
Range(Range("A2:K2"), Range("A2:K2").End(xlDown)).Copy
Workbooks("Datamatchningsfil.xlsm").Sheets("TechData").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
7
Call Continue
End Sub
Sub Continue()
' Utför text till kolumn
Application.Goto Sheets("Produktdata").Range("C:C")
Columns("C:C").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Application.Goto Sheets("CDPPT").Range("F:F")
Columns("F:F").Select
Selection.TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Application.Calculation = xlCalculationAutomatic
ActiveWorkbook.RefreshAll
'Lägger in år och månad i blad arbetsbeskrivning
Application.Goto Sheets("CDPPT").Range("G2")
Range("G2").Copy
Sheets("Arbetsbeskrivning").Select
Range("C10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D10").Activate
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-1],2)"
Range("D10").Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("D10").Select
Selection.TextToColumns Destination:=Range("D10"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Range("D9").Activate
ActiveCell.FormulaR1C1 = "=VLOOKUP(R[1]C,Datalistor!R[-6]C[1]:R[5]C[2],2,0)"
Range("C9").Activate
ActiveCell.FormulaR1C1 = "=Left(R[1]C,4)"
Range("C4").Activate
' kopierar data och skapar Pivotdata Telia försäljning
Sheets("CDPPT").Select
Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Copy
Destination:=Sheets("Matchning"). _
Range("A2")
Application.CutCopyMode = False
Sheets("CDPPT").Select
Range(Range("A2"), Range("A2").End(xlToRight).End(xlDown)).Copy
Destination:=Sheets("Pivotgrund"). _
Range("A2")
Application.CutCopyMode = False
ActiveWorkbook.RefreshAll
' Tar bort dubletter
Application.Goto Sheets("Matchning").Range("A:M")
Selection.Sort Key1:=Range("F1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Application.Goto Sheets("Matchning").Range("A1")
Range(Range("A1"), Range("A1").End(xlToRight).End(xlDown)).Select
ActiveSheet.Range("A:L").RemoveDuplicates Columns:=6, Header:= _
xlYes
ActiveWorkbook.RefreshAll
' letar in Pivotdata
Application.Goto Sheets("Matchning").Range("H2")
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-2],Pivot!C[-7]:C[-6],2,0)"
Range("H2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
ActiveWorkbook.RefreshAll
' Skapar fil med prod med saknad data
Application.Goto Sheets("Matchning").Range("A1")
Range("A1").Select
ActiveSheet.Range("$A:P").AutoFilter Field:=12, Criteria1:= _
"Check for data"
Range(Range("A1"), Range("A1").End(xlToRight).End(xlDown)).Copy
Range("A1").Select
Workbooks.Add
ActiveSheet.Paste
ActiveWorkbook.Windows(1).Caption = "Produktdata saknas"
Columns("M:P").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Windows("Datamatchningsfil.xlsm").Activate
Application.Goto Sheets("Matchning").Range("A1")
ActiveSheet.ShowAllData
ActiveWorkbook.RefreshAll
Application.ScreenUpdating = True
Sheets("Arbetsbeskrivning").Select
Range("C13").Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = _
"Steg 1 klart!"
Range("C14").Select
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Steg 1 klart")
End Sub
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
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.