Excel Macro - Move data from Rows to Columns then Delete duplicate lines.

[StephenMatthews]

Hi Guys,



I have an Excel spreadsheet that lists various lines of data for hundreds of addresses, under each address there is a list of products but what I want is to transfer those lines of data from column B into columns C, D & E with an "X" or a "Tick" as per the example below and then delete the duplicate line/s so only one address line is listed showing the products in their designated columns. I have branch numbers ie 000789 which could be used to identify the branch as opposed to an address which could be subject to errors. I would like a Macro to do this for me and would need to create the additional columns being C, D & E with the headings and then move the data from Column B into the assigned columns. I hope someone can help me with this, I tried IF formulas but would prefer a Macro so when I run the Report it does all this automatically for me.

	A	B	C	D	E
1	Address	List	Sandwich	Sweets	Drink
2	High Street, London	Sweets		X	X
3	High Street, London	Drinks
4	Park Road, London	Sandwich	X		X
5	Park Road, London	Drink
6	The Avenue, Coventry	Sandwich	X	X
7	The Avenue, Coventry	Sweets

Thanks



Stephen.

 

[Joe4]

Assuming that your data is structured as shown, with entries just in columns A and B (and nothing initially in C,D, or E) and your headers are on row 1 and your data starts on row 2, try the following:

Sub MyMacro()

    Dim myLastRow As Long
    Dim myRow As Long
    Dim myRange As Range
    
'   Set heading in row 1 row columns C-E
    Range("C1") = "Sandwich"
    Range("D1") = "Sweets"
    Range("E1") = "Drink"
    
'   Find last row in column A
    myLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Set range for formulas
    Set myRange = Range("C2:E" & myLastRow)
    
'   Enter formulas in cells C2 to end of column E
    myRange.FormulaR1C1 = _
        "=IF(COUNTIFS(R2C1:R7C1,RC1,R2C2:R7C2,R1C)>0,""X"","""")"

'   Convert entries to hard-coded values
    myRange.Copy
    myRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False

'   Delete column B
    Columns("B:B").Delete Shift:=xlToLeft
    
'   Remove duplicates
    Set myRange = Range("A1:D" & myLastRow)
    myRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
        Header:=xlYes

End Sub

 

[StephenMatthews]

Hi Joe,

The Macro worked which is great but that was just an example spreadsheet, can you advise what the code would be with the following criteria on my spreadsheet:

Columns: A-AA
Rows: 1-919 but this needs to be infinite
List Column: Example was in "B" but is in Column "F"
Fields C-E are not empty on my spreadsheet so additional 3 columns need adding after Column F.

I tried tweaking the COUNTIFS formula to suite but was confused by R2 and R7.

In principle this does everything I want just need the code changing a little, I though it would be simple enough to change the Letter C to G on the formula but this didn't work.

Anyway I'm sure it is simple enough to change but not seeing it!

Thanks

Stephen.

Assuming that your data is structured as shown, with entries just in columns A and B (and nothing initially in C,D, or E) and your headers are on row 1 and your data starts on row 2, try the following:

Sub MyMacro()

    Dim myLastRow As Long
    Dim myRow As Long
    Dim myRange As Range
    
'   Set heading in row 1 row columns C-E
    Range("C1") = "Sandwich"
    Range("D1") = "Sweets"
    Range("E1") = "Drink"
    
'   Find last row in column A
    myLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
'   Set range for formulas
    Set myRange = Range("C2:E" & myLastRow)
    
'   Enter formulas in cells C2 to end of column E
    myRange.FormulaR1C1 = _
        "=IF(COUNTIFS(R2C1:R7C1,RC1,R2C2:R7C2,R1C)>0,""X"","""")"

'   Convert entries to hard-coded values
    myRange.Copy
    myRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveSheet.Paste
    Application.CutCopyMode = False

'   Delete column B
    Columns("B:B").Delete Shift:=xlToLeft
    
'   Remove duplicates
    Set myRange = Range("A1:D" & myLastRow)
    myRange.RemoveDuplicates Columns:=Array(1, 2, 3, 4), _
        Header:=xlYes

End Sub

 

[Joe4]

The code, as I have written it, will dynamically select the number if rows, regardless of how many there are. The only thing you may need to change is which column you need to look at to figure out the last row, if column A won't work. You would just change the "A" in the myLastRow formula to whatever row you need to look at.

Regarding the R2 and R7 notation, see here for an explanation on that: R1C1, the unused Excel cell reference system | Numbergrinder. You know how I got that formula? I didn't write it from scratch. I turned on the Macro Recorder, and entered in the formula that I needed in the first cell right on the Excel page, in regular notation. Then stopped the Macro Recorder, and viewed the code that I recorded. Using the relative cell referencing handles the issues of how to change the row and column references as you move across/down. The Macro Recorder is a great tool to use for his sort of stuff. It can get you all sorts of VBA code.

You obviously would also need to change the myRange calculation, to make sure it is including the correct column references (instead of columns C through E).

Try incorporating these tips/tricks and see if you and figure it out. If you run into issues, post the VBA code with your edits, and let me know what is not working right, and I will help you clean it up. I would just need to know one thing. If you list is in column F, does that mean that the values you are looking at are in columns G to AA?