RINCONPAUL
07-31-2015, 04:27 PM
I have recorded a macro but it's pretty long. It's basically: At source Sheet1, select copy from col B, move to Sheet5 sort and remove duplicates and paste in col A. Then repeat loop but this time move across one column at source B to C and return to Sheet 5 and paste two cols over from previous Col C to E. Repeat loop.
So, it's shunting across one column at source and two columns at destination sheet, each loop. The source sheet starts at col B and ends at col Y. The destination sheet starts at col A and finishes at col AU. Code attached for two cycles of the loop.
Thanks for reading :)
#Sub Criteriadropdownpaste()
'
' Criteriadropdownpaste Macro
'
'
Sheets("Sheet1").Select
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("A2:A20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$A$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes
Sheets("Sheet1").Select
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("C2:C20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$C$1:$C$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes#
So, it's shunting across one column at source and two columns at destination sheet, each loop. The source sheet starts at col B and ends at col Y. The destination sheet starts at col A and finishes at col AU. Code attached for two cycles of the loop.
Thanks for reading :)
#Sub Criteriadropdownpaste()
'
' Criteriadropdownpaste Macro
'
'
Sheets("Sheet1").Select
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("A2:A20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$A$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes
Sheets("Sheet1").Select
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("C2:C20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$C$1:$C$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes#